Session Types_To_Sets_Extension

Theory ETTS_Tools

(* Title: ETTS/ETTS_Tools/ETTS_Tools.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

A collection of basic Isabelle/ML functions for the ETTS.
*)

section‹Import›
theory ETTS_Tools
  imports "Conditional_Transfer_Rule.CTR_Tools"
begin



subsection‹Auxiliary›

lemma tr_to_tr_rel: "A b c  (Transfer.Rel A) b c"
  unfolding Transfer.Rel_def .



subsection‹Standard library extension›

ML_file "More_Library.ML"
ML_file "More_Term.ML"
ML_file "More_Logic.ML"
ML_file "More_Tactical.ML"
ML_file "More_Simplifier.ML"
ML_file "More_HOLogic.ML"
ML_file "More_Transfer.ML"



subsection‹Specialized functionality›

ML_file "ETTS_Writer.ML"

end

File ‹More_Library.ML›

(* Title: ETTS/ETTS_Tools/More_Library.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Library from the standard library of 
Isabelle/Pure.
*)

signature LIBRARY =
sig

  include LIBRARY

  (*functions*)
  val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
  
  (*lists*)
  val list_of_pair : 'a * 'a -> 'a list
  val pair_of_list : 'a list -> 'a * 'a
  val list_of_triple : 'a * 'a * 'a -> 'a list
  val triple_of_list : 'a list -> 'a * 'a * 'a
  val compare_each : ('a * 'b -> 'c) -> 'a list -> 'b list -> 'c list
  val numdup : ('a * 'a -> bool) -> 'a list -> int
  val rotate_list : 'a list -> 'a list
  
  (*integers*)
  val min_list : int list -> int

end;

structure Library: LIBRARY =
struct

open Library;

(** functions **)

fun flip f x y = f y x


(** lists **)

fun list_of_pair (x, y) = [x, y];
fun pair_of_list [x, y] = (x, y)
  | pair_of_list _ = raise Fail "pair_of_list";
fun list_of_triple (x, y, z) = [x, y, z];
fun triple_of_list [x, y, z] = (x, y, z)
  | triple_of_list _ = raise Fail "triple_of_list";

fun compare_each _ [] [] = []
  | compare_each eq (x::xs) (y::ys) = (eq (x, y)) :: compare_each eq xs ys
  | compare_each _ [] (_::_) = raise Empty
  | compare_each _ (_::_) [] = raise Empty;

fun numdup eq xs = length xs - length (distinct eq xs);

fun rotate_list xs = tl xs @ [hd xs];


(** integers **)

fun min_list xs = 
  fold (fn x => fn min => if x < min then x else min) (tl xs) (hd xs);

end;

open Library;

File ‹More_Term.ML›

(* Title: ETTS/ETTS_Tools/More_Term.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Term from the standard library of 
Isabelle/Pure.
*)

signature TERM =
sig
  include TERM
  val is_cv : term -> bool
  val sort_of_tvar : typ -> sort
  val sort_eqT : theory -> typ * typ -> bool
end;

structure Term: TERM  =
struct

open Term;

fun is_cv t = is_Const t orelse is_Var t

fun sort_of_tvar (TVar (_, S)) = S
  | sort_of_tvar (TFree (_, S)) = S
  | sort_of_tvar T = 
      raise TYPE ("the type is not a type variable", single T, [])

fun sort_eqT thy (T, U) =
  let val algebra = Sign.classes_of thy
  in Sorts.sort_eq algebra (sort_of_tvar T, sort_of_tvar U) end;

end;

File ‹More_Logic.ML›

(* Title: ETTS/ETTS_Tools/More_Logic.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Logic from the standard library of 
Isabelle/Pure.
*)

signature LOGIC =
sig
  include LOGIC
  val forall_elim_all : term -> term * (string * typ) list
  val get_forall_ftv_permute : term -> term * ((string * typ) list * int list)
end

structure Logic: LOGIC  =
struct

open Logic;

(*forall elimination*)
fun forall_elim_all t =
  let
    fun forall_elim_all_impl t ftv_specs = 
      let val (ftv_spec, t) = Logic.dest_all t 
      in forall_elim_all_impl t (ftv_spec::ftv_specs) end
      handle TERM ("dest_all", _) => (t, ftv_specs)
  in forall_elim_all_impl t [] ||> rev end;

(*indices of the universally quantified variables with respect to the 
order of their appearance in the term in the sense of Term.add_frees*)
fun get_forall_ftv_permute t =
  let
    val (t', forall_ftv_specs) = forall_elim_all t
    val ftv_specs = Term.add_frees t' [] |> rev
    val call_ftv_specs = ftv_specs 
      |> subtract op= (ftv_specs |> subtract op= forall_ftv_specs)
    val index_of_ftv = 
      (call_ftv_specs ~~ (0 upto (length call_ftv_specs - 1)))
      |> AList.lookup op= #> the
    val forall_ftv_permute = map index_of_ftv forall_ftv_specs
  in (t', (forall_ftv_specs, forall_ftv_permute)) end;

end;

File ‹More_Tactical.ML›

(* Title: ETTS/ETTS_Tools/More_Tactical.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Tactical from the standard library of 
Isabelle/Pure.
*)

signature TACTICAL =
sig
  include TACTICAL
  val FIRST_APPEND' : ('a -> tactic) list -> 'a -> tactic
end;

structure Tactical: TACTICAL =
struct

open Tactical;

(*based on the tactical FIRST in the main distribution*)
fun FIRST_APPEND' tacs = fold_rev (curry op APPEND') tacs (K no_tac);

end;

open Tactical;

File ‹More_Simplifier.ML›

(* Title: ETTS/ETTS_Tools/More_Simplifier.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Simplifier from the standard library of 
Isabelle/Pure.

Notes: 
  - The structure More_Simplifier was copied from the file 
  HOL/Types_To_Sets/Examples/Prerequisites.thy (with amendments)
*)

structure More_Simplifier =
struct

open More_Simplifier;

fun rewrite_simp_opt' ctxt simp_spec_opt = case simp_spec_opt of 
    SOME simp_spec => 
      var_simplify_only 
        ctxt 
        (Attrib.eval_thms ctxt (single simp_spec)) 
  | NONE => Simplifier.full_simplify ctxt;

end;

File ‹More_HOLogic.ML›

(* Title: ETTS/ETTS_Tools/More_HOLogic.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure HOLogic from the standard library of 
Isabelle/Pure.
*)

signature HOLOGIC =
sig
  include HOLOGIC
  val dest_exists :  term -> string * typ * term
  val mk_type_definition_pred : typ -> typ -> term
  val dest_type_definition : term -> term * term * term
  val is_binrelvarT : typ -> bool
  val dest_SetT : typ -> typ
  val dest_SetTFree: typ -> string * sort 
  val is_setT : typ -> bool
  val is_var_setT : typ -> bool
end;

structure HOLogic: HOLOGIC =
struct

open HOLogic;

fun dest_exists ((Const (const_name‹HOL.Ex›, _) $ Abs (c, U, t))) = (c, U, t)
  | dest_exists t = raise TERM ("dest_exists", single t);

fun mk_type_definition_pred T U = Const 
  (
    const_name‹type_definition›,
    (T --> U) --> (U --> T) --> HOLogic.mk_setT U --> HOLogic.boolT
  );

fun dest_type_definition
  (Const (const_name‹type_definition›, _) $ rept $ abst $ sett) = 
    (rept, abst, sett)
  | dest_type_definition t = raise TERM ("dest_type_definition", single t);

fun is_binrelvarT 
    (
      Type 
        (
          type_name‹fun›, 
            [
              TVar sT,
              Type (type_name‹fun›, [TVar sU, Type (type_name‹HOL.bool›, [])])
            ]
        )
    ) = not (sT = sU)
  | is_binrelvarT _ = false;

fun is_setT (Type (type_name‹Set.set›, _)) = true
  | is_setT _ = false

fun is_var_setT (Type (type_name‹Set.set›, [TVar _])) = true
  | is_var_setT (Type (type_name‹Set.set›, [TFree _])) = true
  | is_var_setT _ = false

fun dest_SetT (Type (type_name‹Set.set›, [T])) = T
  | dest_SetT T = raise TYPE("dest_SetT", single T, []);

fun dest_SetTFree (Type (type_name‹Set.set›, [T])) = dest_TFree T
  | dest_SetTFree T = raise TYPE("dest_SetTFree", single T, []);

end;

File ‹More_Transfer.ML›

(* Title: ETTS/ETTS_Tools/More_Transfer.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Transfer from the standard library of 
Isabelle/Pure.
*)

signature TRANSFER =
sig
  include TRANSFER
  val mk_rel_sc : string -> term -> term
  val mk_bi_unique : term -> term
  val mk_right_total : term -> term  
  val mk_transfer_rels : thm list -> thm list
end

structure Transfer: TRANSFER  =
struct

open Transfer;

fun mk_rel_sc c t = Const (c, type_of t --> HOLogic.boolT) $ t;
fun mk_bi_unique t = mk_rel_sc const_name‹Transfer.bi_unique› t;
fun mk_right_total t = mk_rel_sc const_name‹Transfer.right_total› t;

(*amend a list of transfer rules with the constant Transfer.Rel*)
fun mk_transfer_rels tr_thms =
  let
    val tr_to_tr_rel_thm = @{thm tr_to_tr_rel};
    val ct = Thm.cprems_of tr_to_tr_rel_thm |> the_single
    val tr_thms = tr_thms
      |> 
        (
          (
            fn tr_thm => 
            Thm.first_order_match (ct, (tr_thm |> Thm.cprop_of))
          )
          |> map
        )
      |> map (fn inst => Drule.instantiate_normalize inst tr_to_tr_rel_thm)
      |> curry (swap #> op~~) (map single tr_thms)
      |> map op OF
  in tr_thms end;

end

File ‹ETTS_Writer.ML›

(* Title: ETTS/ETTS_Tools/ETTS_Writer.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

An extension of the structure Writer from the standard library of 
Isabelle/Pure.
*)

signature ETTS_WRITER =
sig
val initialize : int -> int list
val increment_index : int -> int list -> int list
val write_action : string -> int list -> int list
end;

structure ETTS_Writer : ETTS_WRITER =
struct

fun initialize length = replicate length 1

fun index_to_string ns = ns 
  |> rev
  |> map Int.toString
  |> String.concatWith ".";

fun increment_index i ns = 
  let
    val i = length ns - i - 1
    val ns = nth_map i (fn n => n + 1) ns
    val (ns_lhs, ns_rhs) = chop i ns
    val ns_lhs = map (K 1) ns_lhs
  in ns_lhs @ ns_rhs end;

fun write_action c ns =
  let
    val c = index_to_string ns ^ ". " ^ c
    val ns = (hd ns + 1) :: tl ns
    val _ = writeln c
  in ns end;

end;

Theory ETTS

(* Title: ETTS/ETTS.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Extension of Types-To-Sets.
*)

section‹Isar commands and default settings for the ETTS›
theory ETTS
  imports
    (*order is important*)
    "ETTS_Tools/ETTS_Tools"
    "Conditional_Transfer_Rule.CTR"
    "HOL-Types_To_Sets.Types_To_Sets"
    "HOL-Eisbach.Eisbach"
  keywords "tts_register_sbts" :: thy_goal_stmt
    and "tts_find_sbts" :: diag
    and "tts_theorem" "tts_lemma" "tts_corollary" "tts_proposition" :: 
      thy_goal_stmt
    and "tts_lemmas" :: thy_defn
    and "tts_context" :: thy_decl_block
    and "tts"
    and "to"
    and "sbterms"
    and "substituting"
    and "given"
    and "applying"
    and "rewriting"
    and "eliminating"
    and "through" 
begin



subsection‹Prerequisites›


subsubsection‹Transfer for local typedef›


text‹
The following content was ported from the content of the session 
Types_To_Sets› in the main library of Isabelle/HOL with minor amendments.
›

context
  fixes Rep Abs A T
  assumes type: "type_definition Rep Abs A"
  assumes T_def: "T  (λ(x::'a) (y::'b). x = Rep y)"
begin

lemma type_definition_Domainp': 
  "is_equality a  Transfer.Rel a (Domainp T) (λx. x  A)"
proof -
  interpret type_definition Rep Abs A by (rule type)
  show "is_equality a  Transfer.Rel a (Domainp T) (λx. x  A)"
    unfolding is_equality_def Transfer.Rel_def
    by (elim ssubst, unfold Domainp_iff[abs_def] T_def fun_eq_iff)  
      (metis Abs_inverse Rep)
qed

lemma type_definition_Domainp: "Domainp T = (λx. x  A)"
proof -
  interpret type_definition Rep Abs A by (rule type)
  show ?thesis
    unfolding Domainp_iff[abs_def] T_def fun_eq_iff by (metis Abs_inverse Rep)
qed

lemma type_definition_Rangep: "Rangep T = (λx. True)"
proof -
  interpret type_definition Rep Abs A by (rule type)
  show ?thesis unfolding T_def by auto
qed

lemma 
  shows rep_in_S[simp]: "Rep x  A" 
    and rep_inverse[simp]: "Abs (Rep x) = x" 
    and Abs_inverse[simp]: "y  A  Rep (Abs y) = y"
  using type unfolding type_definition_def by auto

end

lemmas [transfer_rule] = ―‹prefer right-total rules›
  right_total_All_transfer
  right_total_UNIV_transfer
  right_total_Ex_transfer


subsubsection‹Auxiliary›

lemma ex_type_definition:   
  fixes A :: "['a, 'b]  bool"
  assumes "right_total A" and "bi_unique A"
  shows 
    "(Rep::'b  'a) (Abs::'a  'b). 
      type_definition Rep Abs (Collect (Domainp A))  
      (b b'. A b b' = (b = Rep b'))"
proof(unfold type_definition_def, intro exI conjI; intro allI)
  define Rep :: "'b  'a" where Rep: "Rep = (λb'. (SOME b. A b b'))"
  define Abs :: "'a  'b" where Abs: "Abs = (λb. (SOME b'. A b b'))"
  have Rep_b: "A (Rep b') b'" for b'
    unfolding Rep by (metis assms(1) right_totalE verit_sko_ex')
  have Abs_a: "b  Collect (Domainp A)  A b (Abs b)" for b
    unfolding Abs by (simp add: assms(1) Domainp_iff someI_ex)
  show "Rep x  Collect (Domainp A)" for x by (auto intro: Rep_b)
  show "Abs (Rep x) = x" for x 
    using assms(2) by (auto dest: bi_uniqueDr intro: Abs_a Rep_b)
  show "y  Collect (Domainp A)  Rep (Abs y) = y" for y 
    using assms(2) by (auto dest: bi_uniqueDl intro: Abs_a Rep_b)
  show "A b b' = (b = Rep b')" for b b'
    using assms(2) by (meson Rep_b bi_uniqueDl)
qed

lemma ex_eq: "x. x = t" by simp



subsection‹Import›

ML_file‹ETTS_Tactics.ML›
ML_file‹ETTS_Utilities.ML›
ML_file‹ETTS_RI.ML›
ML_file‹ETTS_Substitution.ML›
ML_file‹ETTS_Context.ML›
ML_file‹ETTS_Algorithm.ML›
ML_file‹ETTS_Active.ML›
ML_file‹ETTS_Lemma.ML›
ML_file‹ETTS_Lemmas.ML›



subsection‹Commands and attributes›

ML (* Adopted (with amendments) from the theory Pure.thy *)
ETTS_Lemma.tts_lemma command_keywordtts_theorem "tts theorem";
ETTS_Lemma.tts_lemma command_keywordtts_lemma "tts lemma";
ETTS_Lemma.tts_lemma command_keywordtts_corollary "tts corollary";
ETTS_Lemma.tts_lemma command_keywordtts_proposition "tts proposition";



subsection‹Default settings›


subsubsectiontext‹tts_implicit›

named_theorems tts_implicit


subsubsectiontext‹tts_transfer_rule›

lemmas [transfer_rule] =
  right_total_UNIV_transfer
  right_total_Collect_transfer
  right_total_Inter_transfer
  right_total_Compl_transfer
  finite_transfer
  image_transfer

end

File ‹ETTS_Tactics.ML›

(* Title: ETTS/ETTS_Tactics.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the tactics for the ETTS.
*)

signature ETTS_TACTICS =
sig
val cond_red_tac : 
  Proof.context ->
  term ->
  (Proof.context -> tactic) ->
  thm -> 
  int -> 
  tactic
val id_tac : thm -> int -> tactic
val prem_red : 
  Proof.context -> (term list * (Proof.context -> tactic)) -> thm -> thm
end;

structure ETTS_Tactics : ETTS_TACTICS =
struct                                           

(*an identity tactic*)
fun id_tac assm_thm i = 
  let fun id_tac_impl assm_thm thm = Thm.implies_elim thm assm_thm;
  in SELECT_GOAL (PRIMITIVE (id_tac_impl assm_thm)) i end;

(*a tactic for the elimination of the first premise using a 
user-defined tactic*)
fun cond_red_tac ctxt condt cond_tac thm i =
  Induct.cases_tac ctxt false ((SOME condt) |> single |> single) NONE [] i
  THEN Local_Defs.unfold_tac ctxt (single @{thm not_not})
  THEN SOLVED' 
    (
      SUBPROOF 
        (
          fn {context, prems, ...} => 
            Method.insert_tac context prems 1 
            THEN (cond_tac context)
        ) 
        ctxt
    ) 
    i
  THEN id_tac thm i;

(*automated elimination of premises*)
fun prem_red ctxt tac_spec thm = 
  let

    fun rotate_prems_once thm = Drule.rotate_prems 1 thm
      handle THM _ => thm
    val aterms = #1 tac_spec

    fun prem_red_rec thm condn = 
      let                      
        val prems = Thm.prems_of thm 
        val condt_opt = 
          let
            fun pass_through_spec t = 
              if null aterms orelse member Term.could_unify aterms t  
              then t 
              else raise TERM ("", [])
          in
            prems 
            |> hd
            |> HOLogic.dest_Trueprop
            |> pass_through_spec
            |> HOLogic.mk_not
            |> SOME
            handle 
                TERM _ => NONE
              | Empty => NONE
          end;
        val thm' = rotate_prems_once thm
        val thm'' = case condt_opt of
          SOME condt =>
            let val goalt = Logic.list_implies (tl prems, (Thm.concl_of thm))
            in
              Goal.prove 
                ctxt 
                [] 
                [] 
                goalt 
                (cond_red_tac ctxt condt (#2 tac_spec) thm' 1 |> K)
              handle 
                  ERROR _ => thm'
                | THM _ => thm'
            end
          | NONE => thm'
        val success_flag = 
          not (Thm.full_prop_of thm'' = Thm.full_prop_of thm')
      in
        if success_flag
        then prem_red_rec thm'' (condn - 1)
        else if condn > 1 then prem_red_rec thm' (condn - 1) else thm
      end

    val thm = Local_Defs.unfold ctxt (single @{thm not_not}) thm
    val condn = thm |> Thm.prems_of |> length
    val out_thm = rotate_prems_once (prem_red_rec thm condn) 

  in out_thm end;

end;

File ‹ETTS_Utilities.ML›

(* Title: ETTS/ETTS_Utilities.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

A collection of unrelated utilities for the ETTS.
*)

signature ETTS_UTILITIES =
sig
val term_name_of_type_name : string -> string
val string_of_token_src_list : Token.src list -> string
end;


structure ETTS_Utilities : ETTS_UTILITIES =
struct

fun term_name_of_type_name c =
  let val s = substring (c, 1, size c - 1)
  in
    if s |> String.explode |> map Char.isAlpha |> List.all I
    then String.map Char.toUpper s
    else "A"
  end;

fun string_of_token_src_list ts = 
  let
    val lhs_cs = map (Token.name_of_src #> fst) ts
    val rhs_cs = ts
      |> map (Token.args_of_src #> map Token.print #> String.concatWith " ") 
    val cs = 
      let
        fun condc (lhs_c, rhs_c) = 
          if rhs_c = "" then lhs_c else lhs_c ^ " " ^ rhs_c 
      in map condc (lhs_cs ~~ rhs_cs) end
  in ML_Syntax.print_list I cs end;

end;

open ETTS_Utilities;

File ‹ETTS_RI.ML›

(* Title: ETTS/ETTS_RI.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the functionality associated with the relativization
isomorphisms.
*)

signature ETTS_RI =
sig
val is_risset : term -> bool
val dest_rissetT : typ -> string * sort
val dest_rissetFree : term -> string * (string * sort)
val ftv_spec_of_rissetT_spec : string -> string * string list
val type_of_rissetT_spec : string -> typ
val fv_spec_of_rissetFree : string * string -> string * typ
val mk_Domainp_sc : term -> term -> term
val risset_input : Proof.context -> string -> term list -> unit
end;


structure ETTS_RI : ETTS_RI =
struct

(*representation/abstraction of the specification of the rissets*)
fun is_risset t = case type_of t of 
    (Type (type_name‹Set.set›, [T])) => is_TFree T
  | _ => false
  andalso Term.add_tvars t [] |> null
  andalso Term.add_vars t [] |> null;
val dest_rissetT = HOLogic.dest_SetTFree;
fun dest_rissetFree (Free (c, T)) = (c, dest_rissetT T)
  | dest_rissetFree t = raise TERM("dest_rissetFree", single t);
fun ftv_spec_of_rissetT_spec (c : string) = (c, sort‹HOL.type›)
fun type_of_rissetT_spec c = 
  Type (type_name‹Set.set›, TFree (ftv_spec_of_rissetT_spec c) |> single);
fun fv_spec_of_rissetFree (tc : string, Tc : string) = 
  (tc, type_of_rissetT_spec Tc);

(*domain transfer rule associated with a relativization isomorphism*)
fun mk_Domainp_sc brelt rissett =
  let
    val T = rissett |> type_of |> dest_rissetT |> TFree
    val lhst = 
      Const 
        (
          const_name‹Relation.Domainp›, 
          (type_of brelt) --> T --> HOLogic.boolT
        ) $ 
        brelt
    val rhst =
      let val U = T --> HOLogic.mk_setT T --> HOLogic.boolT 
      in Abs ("x", T, Const (const_name‹Set.member›, U) $ Bound 0 $ rissett) end
  in HOLogic.mk_eq (lhst, rhst) end;

(*elements of the input error verification for the RIs*)
local

fun get_tvs t = t
  |> (fn t => (Term.add_tvars t [], Term.add_tfrees t []))
  |>> map TVar
  ||> map TFree
  |> op@;

fun ntv_eq ((TVar (xi, _)), (TVar (xi', _))) = Term.eq_ix (xi, xi')
  | ntv_eq (TFree (c, _), TFree (c', _)) = c = c'
  | ntv_eq (_, _) = false;

fun ex_eq_sorts_neq_ntvs thy = 
  partition_eq ntv_eq 
  #> map (distinct (Term.sort_eqT thy)) 
  #> exists (fn xs => 1 < length xs);

fun get_vs t = t
  |> (fn t => (Term.add_vars t [], Term.add_frees t []))
  |>> map Var
  ||> map Free
  |> op@;

fun tv_eq ((Var (xi, _)), (Var (xi', _))) = Term.eq_ix (xi, xi')
  | tv_eq (Free (c, _), Free (c', _)) = c = c'
  | tv_eq (_, _) = false;

fun type_eqT (t, u) =
  let
    val get_varT = type_of #> HOLogic.dest_SetT
    val T = get_varT t 
    val U = get_varT u
  in ntv_eq (T, U) end;

val ex_eq_types_neq_nvs = partition_eq tv_eq
  #> map (distinct type_eqT)
  #> exists (fn xs => 1 < length xs);

in

fun risset_input ctxt c risset = 
  let

    fun mk_msg_prefix msg = c ^ ": " ^ msg 

    val msg_riss_not_set = mk_msg_prefix
      "risset must be terms of the type of the form ?'a set or 'a set"
    val msg_riss_not_ds_dtv = mk_msg_prefix 
      "risset: type variables with distinct sorts must be distinct"
    val msg_riss_not_dt_dv = mk_msg_prefix 
      "risset: variables with distinct types must be distinct"

    val _ = risset |> map (type_of #> HOLogic.is_var_setT) |> List.all I
      orelse error msg_riss_not_set
    val _ = risset 
      |> map get_tvs
      |> flat
      |> ex_eq_sorts_neq_ntvs (Proof_Context.theory_of ctxt)
      |> not
      orelse error msg_riss_not_ds_dtv
    val _ = risset
      |> map get_vs
      |> flat
      |> ex_eq_types_neq_nvs 
      |> not
      orelse error msg_riss_not_dt_dv

  in () end;

end;

end;

File ‹ETTS_Substitution.ML›

(* Title: ETTS/ETTS_Substitution.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the functionality associated with the sbterms.
*)

signature ETTS_SUBSTITUTION =
sig
val sbt_data_of : Proof.context -> Ctermtab.key -> thm option
val is_sbt_data_key : Proof.context -> cterm -> bool
val process_tts_register_sbts : 
  string * string list -> Proof.context -> Proof.state
end;


structure ETTS_Substitution : ETTS_SUBSTITUTION =
struct




(**** Prerequisites ****)

open ETTS_Utilities;
open ETTS_RI;




(**** Data containers ****)



(*** Data ***)

structure SBTData_Args =
struct
  type T = thm Ctermtab.table
  val empty = Ctermtab.empty
  val extend = I
  val merge : (T * T -> T) = Ctermtab.merge (K true)
  fun init _ = Ctermtab.empty
end;
structure Global_SBTData = Theory_Data (SBTData_Args);
structure Local_SBTData = Proof_Data (SBTData_Args);



(*** Generic operations ***)

val sbt_data_of = Local_SBTData.get #> Ctermtab.lookup;
val sbt_data_keys = Local_SBTData.get #> Ctermtab.keys
fun map_sbt_data f (Context.Proof ctxt) = ctxt 
      |> Local_SBTData.map f 
      |> Context.Proof 
  | map_sbt_data f (Context.Theory thy) = thy 
      |> Global_SBTData.map f 
      |> Context.Theory;
fun update_sbt_data k v =
  let
    fun declaration phi = (Morphism.cterm phi k, Morphism.thm phi v) 
      |> Ctermtab.update 
      |> map_sbt_data
  in Local_Theory.declaration {pervasive=true, syntax=false}  declaration end;

fun is_sbt_data_key ctxt ct = member (op aconvc) (sbt_data_keys ctxt) ct;



(**** Evaluation : tts_find_sbts *****)

fun process_tts_find_sbts args st = 
  let 
    val ctxt = Toplevel.context_of st
    val args = case args of
        [] => sbt_data_keys ctxt
      | args => map (ctxt |> Syntax.read_term #> Thm.cterm_of ctxt) args
  in
    args
    |> map (sbt_data_of ctxt #> the #> Thm.string_of_thm ctxt |> apdupr)
    |> map (Thm.term_of #> Syntax.string_of_term ctxt |> apfst) 
    |> map ((fn (c, thmc) => c ^ " : " ^ thmc) #> writeln)
    |> K ()
  end;




(**** Parser : tts_find_sbts ****)

val parse_tts_find_sbts = Parse.and_list Parse.term;




(**** Interface : tts_find_sbts *****)

val _ = Outer_Syntax.command
  command_keywordtts_find_sbts
  "lookup a theorem associated with a constant or a fixed variable"
  (parse_tts_find_sbts >> (process_tts_find_sbts #> Toplevel.keep));




(**** Evaluation : tts_register_sbts *****)

local 

fun mk_msg_tts_register_sbts msg = "tts_register_sbts: " ^ msg;

(*create the goals for the function register_sbts_cmd*)
fun mk_goal_register_sbts ctxt sbt risset =
  let

    val msg_repeated_risset = mk_msg_tts_register_sbts
      "the type variables associated with the risset must be distinct"

    (*auxiliary functions*)
    fun mk_rel_assms (brelt, rissett) = 
      [
        mk_Domainp_sc brelt rissett, 
        Transfer.mk_bi_unique brelt, 
        Transfer.mk_right_total brelt
      ];

    (*risset → unique ftvs of risset*)
    val rissetftv_specs = map (type_of #> dest_rissetT) risset

    (*input verification*)
    val _ = rissetftv_specs 
      |> has_duplicates op= 
      |> not orelse error msg_repeated_risset

    (*sbt → (sbt, ftvs of sbt)*)
    val sbt = sbt |> (type_of #> (fn t => Term.add_tfreesT t []) |> apdupr)

    (*
      (sbt, ftvs of sbt), rissetftv_specs → 
        ((sbtftv_int, rcdftv_int)s, (sbtftv_sub, rcdftv_sub)s), ctxt),
      where
        sbtftv_ints = unique ftvs of sbt ∩ ftvs of risset
        sbtftv_subs = unique ftvs of sbt - ftvs of risset
    *)
    val (sbtftv_specs, ctxt) = 
      let
        fun mk_ri_rhs_Ts ctxt f = map (apdupr f)
          #> map_slice_side_r (fn Ss => Variable.invent_types Ss ctxt)
      in
        sbt 
        |> #2  
        |> distinct op=
        |> dup
        |>> inter op= rissetftv_specs
        ||> subtract op= rissetftv_specs
        |>> mk_ri_rhs_Ts ctxt (K sort‹HOL.type›) 
        |>> swap
        |> reroute_ps_sp     
        |> swap
        |>> apsnd (map dup)
      end

    (*(sbt, ftvs of sbt) → (sbt, sbtftv_ints)*)
    val sbt = apsnd (filter (member op= (sbtftv_specs |> #1 |> map #1))) sbt

    (* 
      (sbtftv_int, rcdftv_int)s, sbtftv_subs) → 
        (((sbtftv, rcdftv), ri brel)s, ctxt) 
    *)
    val (sbtftv_specs, ctxt') =
      let val un_of_typ = #1 #> term_name_of_type_name 
      in 
        sbtftv_specs
        |>> map (apfst un_of_typ #> apsnd un_of_typ |> apdupr)
        |>> map (apsnd op^) 
        |>> map_slice_side_r (fn cs => Variable.variant_fixes cs ctxt)
        |>> (apfst TFree #> apsnd TFree |> apdupr |> apfst |> map |> apfst) 
        |>> (reroute_ps_sp |> map |> apfst)
        |>> (swap #> HOLogic.mk_rel |> apsnd |> map |> apfst)
        |>> swap
        |> reroute_ps_sp
        |> swap
        |>> (#1 #> TFree #> HOLogic.eq_const |> apdupr |> map |> apsnd)
      end
    
    (*((sbtftv, rcdftv), ri brel)s, ctxt  → (premises, conclusion)*)
    val sbt_specs =
      let 
        val ftv_map = sbtftv_specs 
          |> #1
          |> map (apfst #1)
          |> AList.lookup op= #> the
        val ftv_map' = sbtftv_specs 
          |> op@
          |> map (apfst #1)
        val risset_of_ftv_spec = ((risset |> map (type_of #> dest_rissetT)) ~~ risset)
          |> AList.lookup op=
        val map_specTs_to_rcdTs = sbtftv_specs
          |> op@
          |> map (#1 #> apsnd TFree)
          |> AList.lookup op= #> the
        val (rct_name, ctxt'') = ctxt' 
          |> Variable.variant_fixes (single "rcdt")
          |>> the_single
      in
        sbt
        |> 
          (
            (
              ftv_map |> apdupl 
              #> (risset_of_ftv_spec #> the |> apsnd)
              #> mk_rel_assms
              |> map 
              #> flat
              #> map HOLogic.mk_Trueprop
              |> apsnd
            )
            #> (#1 #> type_of |> apdupl)
            #> (ftv_map' |> CTR_Relators.pr_of_typ ctxt'' |> apfst)
          )
        |> (fn x => (x, rct_name))
        |> 
          (
            (#1 #> #2 #> #1 #> type_of |> apdupr)
            #> (map_specTs_to_rcdTs |> map_type_tfree |> apsnd)
            #> reroute_ps_sp 
            #> (Free |> apdupl |> apsnd) 
          )
        |> reroute_sp_ps
        |> 
          (
            apfst reroute_sp_ps 
            #> reroute_ps_sp 
            #> apsnd swap 
            |> apfst
            #> apfst reroute_sp_ps 
            #> reroute_ps_sp 
            #> apsnd swap  
            #> reroute_sp_ps 
          )
        |> 
          (
            apfst op$ 
            #> op$ 
            |> apfst
            #> swap
            #> reroute_ps_triple 
            #> HOLogic.mk_exists 
            #> HOLogic.mk_Trueprop
            #> Syntax.check_term ctxt''
            |> apfst 
          )
        |> swap  
      end

    (*introduce the side conditions for each ex_pr*)
    val goal = 
      let
        fun add_premts (premts, conclt) = fold_rev 
          (fn premt => fn t => Logic.mk_implies (premt, t)) 
          premts
          conclt
      in add_premts sbt_specs end

   in (goal, ctxt') end 

in

(*implementation of the functionality of the command tts_register_sbts*)
fun process_tts_register_sbts args ctxt = 
  let 

    (*error messages*)

    val msg_fv_not_fixed = mk_msg_tts_register_sbts
      "all fixed variables that occur in the sbterm " ^
      "must be fixed in the context"
    val msg_ftv_not_fixed = mk_msg_tts_register_sbts
      "all fixed type variables that occur in the sbterm " ^
      "must be fixed in the context"
    val msg_sv = mk_msg_tts_register_sbts
      "the sbterm must contain no schematic variables"
    val msg_stv = mk_msg_tts_register_sbts
      "the sbterm must contain no schematic type variables"

    (*pre-processing and input verification*) 
   
    val sbt = args 
      |> #1 
      |> Syntax.read_term ctxt
    val risset = args
      |> #2
      |> map (Syntax.read_term ctxt)

    val _ = ETTS_RI.risset_input ctxt "tts_register_sbts" risset
    
    val _ = sbt
      |> (fn t => Term.add_frees t [])
      |> distinct op=
      |> map #1
      |> map (Variable.is_fixed ctxt)
      |> List.all I
      orelse error msg_fv_not_fixed
    val _ = sbt
      |> (fn t => Term.add_tfrees t [])
      |> distinct op=
      |> map #1
      |> map (Variable.is_declared ctxt)
      |> List.all I
      orelse error msg_ftv_not_fixed
    val _ = sbt
      |> (fn t => Term.add_vars t [])
      |> length
      |> curry op= 0
      orelse error msg_sv
    val _ = sbt
      |> (fn t => Term.add_tvars t [])
      |> length
      |> curry op= 0
      orelse error msg_stv

    (*main*)

    val (goalt, _) = mk_goal_register_sbts ctxt sbt risset
    val goal_specs = (goalt, []) |> single |> single

    val ct = Thm.cterm_of ctxt sbt

    fun after_qed thmss lthy = update_sbt_data ct (thmss |> hd |> hd) lthy

  in Proof.theorem NONE after_qed goal_specs ctxt end;

end;




(**** Parser : tts_register_sbts ****)

val parse_tts_register_sbts =
  Parse.term -- (keyword| |-- Parse.and_list Parse.term);




(**** Interface : tts_register_sbts ****)

val _ = Outer_Syntax.local_theory_to_proof
  command_keywordtts_register_sbts
  "command for the registration of the set-based terms"
  (parse_tts_register_sbts >> process_tts_register_sbts)

end;

File ‹ETTS_Context.ML›

(* Title: ETTS/ETTS_Context.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the command tts_context.
*)

signature ETTS_CONTEXT =
sig
type ctxt_def_type
type amend_ctxt_data_input_type
val rule_attrb : string list
val update_tts_ctxt_data : ctxt_def_type -> Proof.context -> Proof.context
val get_tts_ctxt_data : Proof.context -> ctxt_def_type
val string_of_sbrr_opt : (Facts.ref * Token.src list) option -> string
val string_of_subst_thms : (Facts.ref * Token.src list) list -> string
val string_of_mpespc_opt : 
  Proof.context -> 
  (term list * (Proof.context -> tactic)) option -> 
  string
val string_of_amend_context_data_args : 
  Proof.context -> amend_ctxt_data_input_type -> string
val string_of_tts_ctxt_data : Proof.context -> ctxt_def_type -> string
val amend_context_data : 
  amend_ctxt_data_input_type -> Proof.context -> ctxt_def_type * Proof.context
val process_tts_context : 
  amend_ctxt_data_input_type -> Toplevel.transition -> Toplevel.transition
end;


structure ETTS_Context : ETTS_CONTEXT =
struct




(**** Data ****)


(*names of selected rule attributes suitable for tts_context*)
val rule_attrb =
  ["OF", "of", "THEN", "where", "simplified", "folded", "unfolded"];

val is_rule_attrb = member op= rule_attrb;

(*
Conventions
 - risstv: type variable associated with an RI specification element
 - risset: set associated with an RI specification element
 - rispec: RI specification
 - tbt: tbterm associated with the sbterm specification element
 - sbt: sbterm associated with the sbterm specification element
 - sbtspec: sbterm specification
 - sbrr_opt: rewrite rules for the set-based theorem
 - subst_thms: known premises for the set-based theorem 
 - mpespc_opt: specification of the elimination of premises in 
    the set-based theorem
 - attrbs: attributes for the set-based theorem
*)
type ctxt_def_type = 
  {
    rispec : (indexname * term) list,
    sbtspec : (term * term) list,
    sbrr_opt : (Facts.ref * Token.src list) option,
    subst_thms : (Facts.ref * Token.src list) list,
    mpespc_opt : (term list * (Proof.context -> tactic)) option,
    attrbs : Token.src list
  };
type amend_ctxt_data_input_type = 
  (
    (
      (
        ((string * string) list * (string * string) list) * 
        (Facts.ref * Token.src list) option
      ) * (Facts.ref * Token.src list) list
    ) * (string list * (Method.text * (Position.T * Position.T))) option
  ) * Token.src list;

(*default values for the data associated with a tts_context*)
val init_ctxt_def_type = 
  {
    rispec = [], 
    sbtspec = [], 
    sbrr_opt = NONE,
    subst_thms = [],
    mpespc_opt = NONE,
    attrbs = []
  };

(*data for tts_context*)
structure TTSContextData = Proof_Data
  (
    type T = ctxt_def_type; 
    fun init _ = init_ctxt_def_type;
  );

fun update_tts_ctxt_data value = TTSContextData.map (K value);
fun get_tts_ctxt_data ctxt = TTSContextData.get ctxt;

fun is_empty_tts_ctxt_data (ctxt_data : ctxt_def_type) = 
  ctxt_data |> #attrbs |> null 
  andalso ctxt_data |> #mpespc_opt |> is_none
  andalso ctxt_data |> #rispec |> null
  andalso ctxt_data |> #sbrr_opt |> is_none
  andalso ctxt_data |> #subst_thms |> null
  andalso ctxt_data |> #sbtspec |> null;




(**** Input processing ****)

fun mk_mpespc_opt ctxt mpespc_opt_raw = 
  let
    fun mk_mpespc_opt_impl ctxt mpespc_raw = 
      let
        fun prem_red_tac ctxt = 
          (Method.evaluate ((#2 #> #1) mpespc_raw) ctxt) []
          |> Context_Tactic.NO_CONTEXT_TACTIC ctxt
        val prems = mpespc_raw 
          |> #1 
          |> map (Proof_Context.read_term_pattern ctxt)
      in (prems, prem_red_tac) end;
  in Option.map (mk_mpespc_opt_impl ctxt) mpespc_opt_raw end;

fun unpack_amend_context_data_args args = 
  let
    val rispec_raw = args |> #1 |> #1 |> #1 |> #1 |> #1
    val sbtspec_raw = args |> #1 |> #1 |> #1 |> #1 |> #2
    val sbrr_opt_raw = args |> #1 |> #1 |> #1 |> #2
    val subst_thms_raw = args |> #1 |> #1 |> #2
    val mpespc_opt_raw = args |> #1 |> #2
    val attrbs_raw = args |> #2
  in 
    (
      rispec_raw, 
      sbtspec_raw, 
      sbrr_opt_raw, 
      subst_thms_raw, 
      mpespc_opt_raw,
      attrbs_raw
    ) 
  end;




(**** String I/O ****)

fun string_of_rispec ctxt = ML_Syntax.print_pair 
  Term.string_of_vname (Syntax.string_of_term ctxt);

fun string_of_term_pair ctxt =
  let val string_of_term = Syntax.string_of_term ctxt
  in ML_Syntax.print_pair string_of_term string_of_term end;

val string_of_sbrr_opt =
  (ML_Syntax.print_pair Facts.string_of_ref string_of_token_src_list)
  |> ML_Syntax.print_option;

val string_of_subst_thms = 
  ML_Syntax.print_pair Facts.string_of_ref string_of_token_src_list
  |> ML_Syntax.print_list;

fun string_of_mpespc_opt ctxt =
  let 
    val tac_c = K "unknown tactic"
    val term_cs = (ML_Syntax.print_list (Syntax.string_of_term ctxt))
  in ML_Syntax.print_pair term_cs tac_c |> ML_Syntax.print_option end;

fun string_of_amend_context_data_args ctxt args =
  let
    val 
      (
        rispec_raw, 
        sbtspec_raw, 
        sbrr_opt_raw, 
        subst_thms_raw, 
        mpespc_opt_raw,
        attrbs_raw
      ) = unpack_amend_context_data_args args
    val rispec_c = rispec_raw
      |> map (ML_Syntax.print_pair I I)
      |> String.concatWith ", "
      |> curry op^ "rispec: "
    val sbtspec_c = sbtspec_raw
      |> map (ML_Syntax.print_pair I I)
      |> String.concatWith ", "
      |> curry op^ "sbtspec: "
    val sbrr_opt_c = sbrr_opt_raw
      |> string_of_sbrr_opt
      |> curry op^ "sbrr_opt: "
    val subst_thms_c = subst_thms_raw
      |> string_of_subst_thms
      |> curry op^ "subst_thms: "
    val mpespc_opt_c = mpespc_opt_raw
      |> mk_mpespc_opt ctxt
      |> string_of_mpespc_opt ctxt
      |> curry op^ "mpespc_opt: "
    val attrbs_c = attrbs_raw
      |> string_of_token_src_list
      |> curry op^ "attrbs: "
    val out_c =
      [
        rispec_c,
        sbtspec_c,
        sbrr_opt_c,
        subst_thms_c,
        mpespc_opt_c,
        attrbs_c
      ]
      |> String.concatWith "\n"
  in out_c end;

fun string_of_tts_ctxt_data ctxt ctxt_data =
  let
    val rispec_c = ctxt_data
      |> #rispec
      |> map (string_of_rispec ctxt)
      |> String.concatWith ", "
      |> curry op^ "rispec: "
    val sbtspec_c = ctxt_data
      |> #sbtspec
      |> map (string_of_term_pair ctxt)
      |> String.concatWith ", "
      |> curry op^ "sbtspec: "
    val sbrr_opt_c = ctxt_data
      |> #sbrr_opt
      |> string_of_sbrr_opt
      |> curry op^ "sbrr_opt: "
    val subst_thms_c = ctxt_data
      |> #subst_thms
      |> string_of_subst_thms
      |> curry op^ "subst_thms: "
    val mpespc_opt_c = ctxt_data
      |> #mpespc_opt
      |> string_of_mpespc_opt ctxt
      |> curry op^ "mpespc_opt: "
    val attrbs_c = ctxt_data
      |> #attrbs
      |> string_of_token_src_list
      |> curry op^ "attrbs: " 
    val out_c =
      [
        rispec_c,
        sbtspec_c,
        sbrr_opt_c,
        subst_thms_c,
        mpespc_opt_c,
        attrbs_c
      ]
      |> String.concatWith "\n"
  in out_c end;




(**** User input analysis ****)

fun mk_msg_tts_ctxt_error msg = "tts_context: " ^ msg;

fun rispec_input ctxt rispec = 
  let

    val msg_rispec_empty = 
      mk_msg_tts_ctxt_error "rispec must not be empty"
    val msg_risstv_not_distinct = 
      mk_msg_tts_ctxt_error "risstvs must be distinct"

    val risstv = map #1 rispec
    val risset = map #2 rispec

    val _ = rispec |> List.null |> not 
      orelse error msg_rispec_empty
    val _ = risstv |> has_duplicates op= |> not 
      orelse error msg_risstv_not_distinct
    
    val _ = ETTS_RI.risset_input ctxt "tts_context" risset

  in () end;

local

fun tv_of_ix (T, U) = 
  let
    fun tv_of_ix ((TVar v), (TFree x)) = [(v, x)]
      | tv_of_ix ((Type (c, Ts)), (Type (d, Us))) = 
          if length Ts = length Us andalso c = d 
          then (Ts ~~ Us) |> map tv_of_ix |> flat
          else raise TYPE ("tv_of_ix", [Type (c, Ts), Type (d, Us)], [])
      | tv_of_ix (T, U) = raise TYPE ("tv_of_ix", [T, U], [])
  in tv_of_ix (T, U) |> distinct op= end

fun is_fun xs = xs |> map fst |> has_duplicates op= |> not
fun is_bij xs = is_fun xs andalso xs |> map snd |> has_duplicates op= |> not

in

fun sbtspec_input ctxt rispec sbtspec =
  let

    val msg_tbts_not_stvs = mk_msg_tts_ctxt_error 
      "the type variables that occur in the tbts must be schematic"
    val msg_tbts_distinct_sorts = mk_msg_tts_ctxt_error 
      "tbts: a single stv should not have two distinct sorts associated with it"
    val msg_not_type_instance = mk_msg_tts_ctxt_error 
      "\n\t-the types of the sbts must be equivalent " ^ 
      "to the types of the tbts up to renaming of the type variables\n" ^
      "\t-to each type variable that occurs among the tbts must correspond " ^ 
      "exactly one type variable among all type " ^
      "variables that occur among all of the sbts"
    val msg_tbts_not_cv = mk_msg_tts_ctxt_error 
      "tbts must consist of constants and schematic variables"
    val msg_tbts_not_distinct = mk_msg_tts_ctxt_error "tbts must be distinct"
    val msg_tbts_not_sbt_data_key = mk_msg_tts_ctxt_error
      "sbts must be registered using the command tts_register_sbts"
    val msg_sbterms_subset_rispec = mk_msg_tts_ctxt_error
      "the collection of the (stv, ftv) pairs associated with the sbterms " ^
      "must form a subset of the collection of the (stv, ftv) pairs " ^
      "associated with the RI specification, provided that only the pairs " ^
      "(stv, ftv) associated with the sbterms such that ftv occurs in a " ^
      "premise of a theorem associated with an sbterm are taken into account"

    val tbts = map #1 sbtspec
    val sbts = map #2 sbtspec

    val _ = (tbts |> map (fn t => Term.add_tfrees t []) |> flat |> null)
      orelse error msg_tbts_not_stvs

    val _ = tbts
      |> map (fn t => Term.add_tvars t []) 
      |> flat
      |> distinct op=
      |> is_fun
      orelse error msg_tbts_distinct_sorts

    val tbts_sbts_Ts = map type_of tbts ~~ map type_of sbts
      |> map tv_of_ix
      |> flat
      |> distinct op=

    val _ = tbts_sbts_Ts
      |> is_bij
      orelse error msg_not_type_instance
      handle TYPE ("tv_of_ix", _, _) => error msg_not_type_instance

    val _ = tbts |> map Term.is_cv |> List.all I 
      orelse error msg_tbts_not_cv
    val _ = tbts |> has_duplicates (op aconv) |> not
      orelse error msg_tbts_not_distinct

    val _ = sbts
      |> map (Thm.cterm_of ctxt #> apdupl (K ctxt)) 
      |> map (uncurry ETTS_Substitution.is_sbt_data_key)
      |> List.all I 
      orelse error msg_tbts_not_sbt_data_key

    val sbt_ftvs = sbts
      |> map (Thm.cterm_of ctxt)
      |> map (ETTS_Substitution.sbt_data_of ctxt)
      |> filter is_some
      |> map the
      |> map Thm.prems_of
      |> flat
      |> map (fn t => Term.add_tfrees t [])
      |> flat

    val tbts_sbts_Ts' = tbts_sbts_Ts
      |> filter (fn (_, ftv) => ftv |> member op= sbt_ftvs)
      |> map (apfst fst)

    val rispec_ftvs_Ts = 
      map (apsnd (fn t => t |> type_of |> HOLogic.dest_SetTFree)) rispec

    val _ = subset op= (tbts_sbts_Ts', rispec_ftvs_Ts)
      orelse error msg_sbterms_subset_rispec

  in () end;

end;

fun sbrr_opt_raw_input ctxt (SOME sbrr_raw) = 
    let val _ = Attrib.eval_thms ctxt (single sbrr_raw) in () end
  | sbrr_opt_raw_input _ NONE = ();

fun subst_thms_input ctxt subst_thms_raw =
  let val _ = Attrib.eval_thms ctxt subst_thms_raw
  in () end;

fun attrbs_input attrbs = 
  let
    val msg_rule_attrbs = mk_msg_tts_ctxt_error
      "attrbs: only " ^ String.concatWith ", " rule_attrb ^ " are allowed"
    val _ = attrbs 
      |> map (map Token.unparse #> hd) 
      |> map is_rule_attrb 
      |> List.all I
      orelse error msg_rule_attrbs
  in () end;

fun tts_context_input (ctxt_data : ctxt_def_type) =
  let val msg_nested_tts_context = mk_msg_tts_ctxt_error "nested tts contexts"
  in is_empty_tts_ctxt_data ctxt_data orelse error msg_nested_tts_context end;




(**** Parser ****)

local

(*Parser for the field 'tts'*)
val parse_tts = 
  let
    val parse_tts_title = (keywordtts -- kw_col); 
    val parse_tts_entry = 
      (kw_bo |-- Parse.type_var -- (keywordto |-- Parse.term --| kw_bc));
  in parse_tts_title |-- Parse.and_list parse_tts_entry end;

(*Parser for the field 'sbterms'*)
val parse_sbterms = 
  let
    val parse_sbterms_title = (keywordsbterms -- kw_col);
    val parse_sbterms_entry = 
      (kw_bo |-- Parse.term -- (keywordto |-- Parse.term --| kw_bc));
  in parse_sbterms_title |-- Parse.and_list parse_sbterms_entry end;

(*Parser for the field 'rewriting'*)
val parse_rewriting = (keywordrewriting |-- Parse.thm);

(*Parser for the field 'substituting'*)
val parse_substituting = (keywordsubstituting |-- Parse.and_list Parse.thm);

(*Parser for the field 'eliminating'*)
val parse_eliminating = 
  let
    val parse_eliminating_pattern = Parse.and_list Parse.term; 
    val parse_eliminating_method = (keywordthrough |-- Method.parse);
  in
    (
      keywordeliminating |--  
      (
        Scan.optional (parse_eliminating_pattern) [] --
        parse_eliminating_method
      )
    ) 
  end;

(*Parser for the field 'applying'*)
val parse_applying = (keywordapplying |-- Parse.attribs);

in

(*Parser for the entire command*)
val parse_tts_context = 
  parse_tts -- 
  Scan.optional parse_sbterms [] --
  Scan.option parse_rewriting --
  Scan.optional parse_substituting [] --
  Scan.option parse_eliminating --
  Scan.optional parse_applying [];

end;




(**** Evaluation ****)

local

fun mk_rispec ctxt rispec_raw = 
  let val ctxt' = Proof_Context.init_global (Proof_Context.theory_of ctxt)
  in 
    rispec_raw
    |> map (ctxt' |> Syntax.parse_typ #> dest_TVar #> #1 |> apfst)
    |> map (ctxt |> Syntax.read_term |> apsnd) 
  end;

fun mk_sbtspec ctxt sbtspec_raw = 
  let val ctxt' = Proof_Context.init_global (Proof_Context.theory_of ctxt)
  in 
    sbtspec_raw
    |> map (ctxt' |> Proof_Context.read_term_pattern |> apfst)
    |> map (ctxt |> Syntax.read_term |> apsnd)
  end;

in 

fun amend_context_data args ctxt =
  let

    (*tts contexts should not be nested*)
    val _ = ctxt |> get_tts_ctxt_data |> tts_context_input

    (*unpacking*)
    val
      (
        rispec_raw,
        sbtspec_raw,
        sbrr_opt_raw,
        subst_thms_raw,
        mpespc_opt_raw,
        attrbs_raw
      ) = unpack_amend_context_data_args args

    (*pre-processing*)
    val rispec = mk_rispec ctxt rispec_raw
    val sbtspec = mk_sbtspec ctxt sbtspec_raw    
    val mpespc_opt = mk_mpespc_opt ctxt mpespc_opt_raw

    (*user input analysis*)
    val _ = rispec_input ctxt rispec
    val _ = sbtspec_input ctxt rispec sbtspec
    val _ = sbrr_opt_raw_input ctxt sbrr_opt_raw
    val _ = subst_thms_input ctxt subst_thms_raw
    val _ = attrbs_input attrbs_raw
   
    (*structure*)
    val ctxt_def : ctxt_def_type = 
      {
        rispec = rispec, 
        sbtspec = sbtspec, 
        subst_thms = subst_thms_raw, 
        sbrr_opt = sbrr_opt_raw,
        mpespc_opt = mpespc_opt,
        attrbs = attrbs_raw
      }

  in (ctxt_def, update_tts_ctxt_data ctxt_def ctxt) end;

end;

(*generate a new context for tts_context*)
(*ported with amendments from target_context.ML*)
fun tts_gen_context args gthy = gthy
  |> Context.cases Named_Target.theory_init Local_Theory.assert
  |> amend_context_data args
  |> snd
  |> Local_Theory.begin_nested
  |> snd;

fun process_tts_context (args: amend_ctxt_data_input_type) =
  Toplevel.begin_nested_target (tts_gen_context args);




(**** Interface ****)

val _ = Outer_Syntax.command 
  command_keywordtts_context 
  "context for the relativization of facts"
  ((parse_tts_context >> process_tts_context) --| Parse.begin);

end;

File ‹ETTS_Algorithm.ML›

(* Title: ETTS/ETTS_Algorithm.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the ERA.
*)

signature ETTS_ALGORITHM =
sig

(*misc*)
val mk_local_typedef_ex : (string * sort) * term -> term
val dest_local_typedef_ex : term -> typ * term

(*output type*)
datatype etts_output_type = default | verbose | active
val etts_output_type_of_string : string -> etts_output_type
val string_of_etts_output_type : etts_output_type -> string 
val is_verbose : etts_output_type -> bool
val is_active : etts_output_type -> bool
val is_default : etts_output_type -> bool

(*relativization*)
val etts_algorithm :
  Proof.context ->
  etts_output_type ->
  int list ->
  (indexname * term) list ->
  (term * term) list ->
  (Facts.ref * Token.src list) option ->
  (Facts.ref * Token.src list) list ->
  (term list * (Proof.context -> tactic)) option -> 
  Token.src list ->
  thm ->
  (thm * int list) * Proof.context
val etts_fact : 
  Proof.context ->
  etts_output_type ->
  int list ->
  (indexname * term) list ->
  (term * term) list ->
  (Facts.ref * Token.src list) option ->
  (Facts.ref * Token.src list) list ->
  (term list * (Proof.context -> tactic)) option ->
  Token.src list ->
  thm list ->
  (thm list * int list) * Proof.context

end;


structure ETTS_Algorithm : ETTS_ALGORITHM =
struct



(**** Prerequisites ****)

open UD_With;
open ETTS_Utilities;
open ETTS_RI;
open ETTS_Substitution;




(**** Misc ****)

fun mk_local_typedef_ex (rcd_spec, rissett) =
  let
    val T = TFree rcd_spec
    val risset_ftv = rissett 
      |> type_of 
      |> (fn T => Term.add_tfreesT T []) 
      |> the_single
      |> TFree
  in 
    HOLogic.mk_exists 
      (
        "rep", 
        T --> risset_ftv,
        HOLogic.mk_exists  
          (
            "abs", 
            risset_ftv --> T,
            HOLogic.mk_type_definition_pred T risset_ftv $ Bound 1 $ Bound 0 $ rissett
          )
      )
  end;

fun dest_local_typedef_ex t = 
  let
    val (_, T', t') = HOLogic.dest_exists t
      handle TERM ("dest_exists", _) => 
        raise TERM ("dest_local_typedef_ex", single t)
    val (_, _, t'') = HOLogic.dest_exists t'
      handle TERM ("dest_exists", _) => 
        raise TERM ("dest_local_typedef_ex", single t)
    val (T''', _) = dest_funT T'
    val t''' = t'' |> HOLogic.dest_type_definition |> #3
  in (T''', t''') end;




(**** Output type ****)

datatype etts_output_type = default | verbose | active;

fun etts_output_type_of_string "" = default
  | etts_output_type_of_string "!" = verbose
  | etts_output_type_of_string "?" = active
  | etts_output_type_of_string _ = 
      error "etts_output_type_of_string: invalid input";

fun string_of_etts_output_type default = "default"
  | string_of_etts_output_type verbose = "verbose"
  | string_of_etts_output_type active = "active";
 
fun is_verbose verbose = true
  | is_verbose _ = false;

fun is_active active = true
  | is_active _ = false;

fun is_default default = true
  | is_default _ = false;




(**** Auxiliary functions ****)



(*** Standard output ***)

fun verbose_writer_prem etts_output_type writer c = 
  if is_verbose etts_output_type 
  then ETTS_Writer.write_action c writer 
  else writer

fun verbose_writer_concl_thms etts_output_type ctxt thms = 
  if is_verbose etts_output_type
  then map (Thm.string_of_thm ctxt #> writeln) thms
  else single ();

fun verbose_writer_concl_types etts_output_type ctxt Ts = 
  if is_verbose etts_output_type
  then map (Syntax.string_of_typ ctxt #> writeln) Ts
  else single ();



(*** Types-To-Sets ***)

(*multiple applications of the function cancel_type_definition*)
fun cancel_type_definition_repeat n thm =
  let
    fun apply_cancel_type_definition 0 thm = thm
      | apply_cancel_type_definition n thm = thm 
          |> Local_Typedef.cancel_type_definition
          |> rotate_prems 1
          |> apply_cancel_type_definition (n - 1)
  in
    thm 
    |> apply_cancel_type_definition n 
    |> rotate_prems (~n) 
  end;



(**** Initialization of the relativization context ****)

local



(*** Auxiliary ***)

(*theorems used for the relativization in conjunction with transfer*)
val risset_tthms = 
  [@{thm type_definition_Domainp}, @{thm type_definition_Domainp'}];
val sc_tthms = 
  [ 
    @{thm typedef_bi_unique},
    @{thm typedef_right_total},
    @{thm typedef_left_unique},
    @{thm typedef_right_unique}
  ];                                       

(*obtain the types associated with a relativization isomorphism*)
fun get_riT rit = rit 
  |> type_of 
  |> (fn T => (T |> binder_types |> the_single, body_type T));

(*create the rhs of the specification of cr*)
fun mk_cr_rhst rept =
  let
    val (isoT, domT) = get_riT rept
    val rhst = 
      Abs 
        (
          "r", 
          domT, 
          Abs 
            (
              "a", 
              isoT, 
              Const (const_name‹HOL.eq›, domT --> domT --> HOLogic.boolT) $ 
                Bound 1 $ 
                (rept $ Bound 0)
           )
        )
  in rhst end;

(*initialization*)
fun etts_rlt_ctxt_intialize rispec = length rispec;

(*declare fresh ris*)
fun etts_rlt_ctxt_mk_fresh_ris ctxt rispec = rispec
  |> map #2
  |> map (fn t => Term.add_frees t [])
  |> flat
  |> dup
  ||> map #1
  ||> Variable.fix_new_vars ctxt
  |>> map Free  
  |-> fold_rev Variable.declare_term;

(*create fresh risstv isomorphic to risset*)
fun etts_rlt_ctxt_mk_fresh_risstv ctxt etts_output_type writer nds rispec = 
  let
    val writer' = verbose_writer_prem 
      etts_output_type writer "types associated with the RIs..."
    val (rispec', ctxt') = ctxt
      |> (sort‹HOL.type› |> replicate nds |> Variable.invent_types)
      |>> curry (swap #> op~~) rispec
    val _ = verbose_writer_concl_types 
      etts_output_type ctxt' (map (#1 #> TFree) rispec')
  in ((writer', rispec'), ctxt') end;

(*assumptions for the local typedef*)
fun etts_rlt_ctxt_mk_ltd_assms ctxt etts_output_type writer rispec = 
  let
    val writer' = verbose_writer_prem 
      etts_output_type writer "assumptions for the local typedef..."
    val (ltd_assms, ctxt') = rispec
      |> 
        (
          apsnd #2 
          #> mk_local_typedef_ex 
          #> HOLogic.mk_Trueprop 
          #> Thm.cterm_of ctxt
          |> map
        )
      |> (fn ltdts => Assumption.add_assumes ltdts ctxt)
    val _  = verbose_writer_concl_thms etts_output_type ctxt' ltd_assms
  in ((writer', ltd_assms), ctxt') end;



(*** Transfer relations associated with relativization isomorphisms ***)

local

fun mk_ex_crt rept =
  let
    val (isoT, domainT) = get_riT rept
    val crT = domainT --> isoT --> HOLogic.boolT
    val rhst = mk_cr_rhst rept
    val t = HOLogic.mk_exists 
      (
        "cr", 
        crT, 
        Const (const_name‹HOL.eq›, crT --> crT --> HOLogic.boolT) $ 
          Bound 0 $ 
          rhst
      )
  in t end;

in

fun etts_rlt_ctxt_mk_crs ctxt etts_output_type writer nds ltd_assms = 
  let
    val writer' = verbose_writer_prem etts_output_type writer "crs..."
    val ((ra_var_specs, ra_thms), ctxt') = ctxt
      |> Obtain.result 
        (K (REPEAT (eresolve_tac ctxt (single @{thm exE}) 1))) ltd_assms
    val repts = ra_var_specs 
      |> map (#2 #> Thm.term_of) 
      |> chop nds
      |> #1
    val ex_cr_thms =
      let 
        val hol_ex_cr_tac = resolve_tac ctxt' (single @{thm ex_eq}) 1
        fun hol_cr_prover thm = 
          Goal.prove ctxt' [] [] thm (K (hol_ex_cr_tac))
      in map (mk_ex_crt #> HOLogic.mk_Trueprop #> hol_cr_prover) repts end
    val ((crts, hol_cr_thms), ctxt'') = ctxt'
      |> Obtain.result 
        (K (REPEAT (eresolve_tac ctxt' (single @{thm exE}) 1))) ex_cr_thms
      |>> (fn x => x |>> map #2 |>> map Thm.term_of)
    val pure_cr_thms = 
      let
        val pure_crts = map Logic.mk_equals (crts ~~ (map mk_cr_rhst repts))
        fun pure_cr_tac thm _ = 
          Object_Logic.full_atomize_tac ctxt'' 1
          THEN resolve_tac ctxt'' (single thm) 1
        fun pure_cr_prover (goal, tac_thm) = 
          Goal.prove ctxt'' [] [] goal (pure_cr_tac tac_thm)
      in map pure_cr_prover (pure_crts ~~ hol_cr_thms) end
    val _  = verbose_writer_concl_thms etts_output_type ctxt'' pure_cr_thms
  in ((writer', ra_thms, crts, pure_cr_thms), ctxt'') end;

end;



(*** Transfer rules for the relativization isomorphisms ***)

fun etts_rlt_ctxt_mk_ri_tr ctxt etts_output_type writer ra_thms pure_cr_thms =  
  let
    val writer' = 
      verbose_writer_prem etts_output_type writer "main transfer rules..."
    val (risset_transfer_thms, sc_transfer_thms) =
      let 
        val OFthms = map list_of_pair (ra_thms ~~ pure_cr_thms)
        val apply_OFthms = 
          map (fn thm => map ((curry op OF) thm) OFthms) #> flat
      in (risset_tthms, sc_tthms) |>> apply_OFthms ||> apply_OFthms end
    val _  = verbose_writer_concl_thms 
      etts_output_type ctxt (risset_transfer_thms @ sc_transfer_thms)
  in (writer', risset_transfer_thms, sc_transfer_thms) end;



(*** Transfer rules for the set-based terms ***)

local

fun get_sc_ex_rissets risset_transfer_thms sc_transfer_thms = 
  let val nds = (length risset_transfer_thms) div (length risset_tthms)
  in
    (risset_transfer_thms, sc_transfer_thms)
    |>> take nds
    ||> chop nds
    ||> (nds |> chop #> #1 |> apsnd)
    ||> op ~~
    |> op ~~
  end;

in

fun etts_rlt_ctxt_mk_sbt_tr 
  ctxt
  etts_output_type 
  writer 
  risset_transfer_thms 
  sc_transfer_thms 
  rispec 
  sbtspec = 
  let
    val writer' = verbose_writer_prem 
      etts_output_type writer "transfer rules for the sbts..."
    val ((sbtspec_specs, pp_thms), ctxt') = 
      let
        val sc_ex_rissets = get_sc_ex_rissets risset_transfer_thms sc_transfer_thms
        val scthms_of_ftv =
          let
            val scthms_ftv = 
              (
                map (#1 #> #2 #> #2 #> type_of #> dest_rissetT) rispec ~~ 
                map reroute_sp_triple sc_ex_rissets
              )
          in AList.lookup op= scthms_ftv end
        fun thm_prem_ftvs thm = thm
          |> Thm.prems_of
          |> map (fn t => Term.add_tfrees t [])
          |> flat
          |> distinct op=
        fun get_sc_ftv_specs (thm_ftv_specs, rvt_ftv_specs) = rvt_ftv_specs
          |> subtract op= (rvt_ftv_specs |> subtract op= thm_ftv_specs)
        fun obtain_prs ctxt ex_pr_thms = case ex_pr_thms of 
            [] => (([], []), ctxt)
          | _ => Obtain.result 
              (K (REPEAT (eresolve_tac ctxt (single @{thm exE}) 1))) 
              ex_pr_thms
              ctxt
      in
        sbtspec
        |>
          (
            (Thm.cterm_of ctxt #> (sbt_data_of ctxt #> the) |> apdupl)
            #> swap
            |> apsnd
            #> reroute_sp_ps
            |> map
          )
        |> map (reroute_ps_sp #> apsnd swap)
        |> 
          (
            (fn (thm, t) => (thm, (thm, t)))
            #> 
              (
                (apfst thm_prem_ftvs) 
                #> (type_of #> (fn t => Term.add_tfreesT t []) |> apsnd)
                #> get_sc_ftv_specs
                #> 
                  (
                    Option.compose (list_of_triple, scthms_of_ftv)
                    #> 
                      (
                        fn xs_opt => case xs_opt of 
                            SOME xs_opt => xs_opt 
                          | NONE => []
                      )
                    |> map 
                    #> flat 
                  )
                |> apsnd
              )
            #> op OF
            |> apsnd 
            |> map
          )
        |> split_list
        ||> obtain_prs ctxt
        |> reroute_sp_ps
        |>> reroute_sp_ps
        |>> apfst op~~
        |>> (#2 |> apsnd |> map |> apfst)
        |>> apsnd Transfer.mk_transfer_rels
      end
    val _  = verbose_writer_concl_thms etts_output_type ctxt' pp_thms
  in ((writer', pp_thms, sbtspec_specs), ctxt') end;

end;



(*** Post-processing ***)


(** Post-processing 1: transfer theorems **)

fun etts_rlt_ctxt_mk_transfer risset_transfer_thms sc_transfer_thms pp_thms = 
  risset_transfer_thms @ sc_transfer_thms @ pp_thms;


(** Post-processing 2: rispec lookup **)

fun etts_rlt_ctxt_mk_rispec rispec = 
  map (#1 #> swap #> apfst #1) rispec;


(** Post-processing 3: sbtspec lookup **)

fun etts_rlt_ctxt_mk_sbtspec sbtspec_specs = 
  let
    val sbtspec_var_specs = sbtspec_specs
      |> filter (apfst is_Var #> #1)
      |> map (apfst dest_Var)
    val sbtspec_const_specs = sbtspec_specs
      |> filter (apfst is_Const #> #1)
      |> map (apfst dest_Const)
  in (sbtspec_var_specs, sbtspec_const_specs) end;


in


(*** Main ***)

fun init_rlt_ctxt ctxt etts_output_type writer rispec sbtspec = 
  let
    val nds = etts_rlt_ctxt_intialize rispec
    val ctxt' = etts_rlt_ctxt_mk_fresh_ris ctxt rispec
    val ((writer', rispec'), ctxt'') = etts_rlt_ctxt_mk_fresh_risstv 
      ctxt' etts_output_type writer nds rispec
    val ((writer'', ltd_assms), ctxt''') = etts_rlt_ctxt_mk_ltd_assms 
      ctxt'' etts_output_type writer' rispec'
    val ((writer''', ra_thms, crts, pure_cr_thms), ctxt'''') = 
      etts_rlt_ctxt_mk_crs ctxt''' etts_output_type writer'' nds ltd_assms
    val rispec'' = rispec' ~~ crts
    val (writer'''', risset_transfer_thms, sc_transfer_thms) = etts_rlt_ctxt_mk_ri_tr 
      ctxt'''' etts_output_type writer''' ra_thms pure_cr_thms
    val ((writer''''', pp_thms, sbtspec_specs), ctxt''''') = 
      etts_rlt_ctxt_mk_sbt_tr 
        ctxt''''
        etts_output_type 
        writer'''' 
        risset_transfer_thms 
        sc_transfer_thms 
        rispec''
        sbtspec
    val transfer_thms = etts_rlt_ctxt_mk_transfer 
      risset_transfer_thms sc_transfer_thms pp_thms
    val rispec''' = etts_rlt_ctxt_mk_rispec rispec''
    val (sbtspec_var_specs, sbtspec_const_specs) = 
      etts_rlt_ctxt_mk_sbtspec sbtspec_specs
  in 
    (
      ctxt,
      ctxt''''',
      writer''''',
      rispec''',
      sbtspec_var_specs,
      sbtspec_const_specs,
      transfer_thms
    )
  end;

end;




(**** Kernel of the relativization algorithm ****)

local



(*** Naming conventions for schematic type variables ***)

fun etts_algorithm_fresh_stv 
  ctxt
  writer
  rispec 
  sbtspec_var_specs 
  sbtspec_const_specs 
  thm =
  let

    val stvs = thm |> Thm.full_prop_of |> (fn t => Term.add_tvars t [])
    val rispec' = rispec
      |> filter (fn (v, _) => member op= (map fst stvs) v)
      |> map (apfst (apdupr ((AList.lookup op= stvs #> the))))
    val thm_stvs =
      let val cs = rispec' |> map fst |> map fst |> map fst
      in stvs |> filter (fn (v, _) => fst v |> member op= cs |> not) end
    val cs =
      let
        fun folder c (cs, nctxt) = 
          let val out = Name.variant c nctxt 
          in (fst out::cs, snd out) end
        val cs = rispec' |> map snd |> map fst
        val nctxt = fold Name.declare cs (Variable.names_of ctxt)
      in fold folder (thm_stvs |> map fst |> map fst) ([], nctxt) |> fst end
    val rhsTs = cs ~~ map (reroute_ps_sp #> snd) thm_stvs
      |> map reroute_sp_ps
      |> map TVar

    val thm' = 
      let val rhs_cT = map (Thm.ctyp_of ctxt) rhsTs
      in Drule.instantiate_normalize (thm_stvs ~~ rhs_cT, []) thm end
    fun thm_stvs_map (v, T) = 
      case AList.lookup op= (thm_stvs ~~ rhsTs) (v, T) of 
          SOME T => T
        | NONE => TVar (v, T)
    val sbtspec_var_specs = sbtspec_var_specs 
      |> map (fn ((v, T), x) => ((v, map_type_tvar thm_stvs_map T), x))
    val sbtspec_const_specs = sbtspec_const_specs 
      |> map (fn ((c, T), x) => ((c, map_type_tvar thm_stvs_map T), x))

    val thm_stvs = thm' |> Thm.full_prop_of |> (fn t => Term.add_tvars t [])
    val thm_stvs_map = map_type_tvar 
      (fn (v, _) => TVar (v, (AList.lookup op= thm_stvs #> the) v))
    val sbtspec_const_specs = sbtspec_const_specs 
      |> map (fn ((c, T), x) => ((c, thm_stvs_map T), x))

  in ((writer, rispec', sbtspec_var_specs, sbtspec_const_specs), thm') end;



(*** Unfold ud_with ***)

fun etts_algorithm_unfold_ud_with 
  ctxt'' 
  etts_output_type 
  writer 
  sbtspec_var_specs
  sbtspec_const_specs
  thm = 
  let

    val writer' = verbose_writer_prem etts_output_type writer "unfold ud_with..."
    val ud_with_thms = ctxt''
      |> UDWithData.get 
      |> map (Local_Defs.meta_rewrite_rule ctxt'')

    val thm' = Local_Defs.unfold ctxt'' ud_with_thms thm

    val stvs = thm' |> Thm.full_prop_of |> (fn t => Term.add_vars t [])
    val consts = thm' |> Thm.full_prop_of |> (fn t => Term.add_consts t [])
    val sbtspec_var_specs = sbtspec_var_specs
      |> filter (fn ((v, T), _) => member op= stvs (v, T))
    val sbtspec_const_specs = sbtspec_const_specs
      |> filter (fn (const, _) => member op= consts const)
    val sbtspec_specs =
      (
        (map (apfst Var) sbtspec_var_specs) @
        (map (apfst Const) sbtspec_const_specs)
      )
    val _ = verbose_writer_concl_thms etts_output_type ctxt'' (single thm')

  in ((writer', sbtspec_specs), thm') end;



(*** Unoverload types ***)

fun etts_algorithm_unoverload_types 
  ctxt' etts_output_type writer rispec sbtspec_specs thm =
  let

    val writer' = 
      verbose_writer_prem etts_output_type writer "unoverload types..."

    val thm' = Unoverload_Type.unoverload_type 
      (Context.Proof ctxt') (rispec |> map (#1 #> #1) |> rev) thm

    val t = Thm.full_prop_of thm
    val n = Logic.count_prems t
   
    val out_t = Thm.full_prop_of thm'
    val out_n = Logic.count_prems out_t

    val out_prem_ts = out_t |> Logic.strip_imp_prems |> drop (out_n - n)

    val out_t' = Logic.list_implies (out_prem_ts, Logic.strip_imp_concl out_t)
    
    val (mapT, mapt) = (Thm.cterm_of ctxt' out_t', Thm.cprop_of thm)
      |> Thm.match 
      |>> map (apfst TVar)
      ||> map (apfst Var)
      |>> map (apsnd Thm.typ_of)
      ||> map (apsnd Thm.term_of)
      |>> map swap
      ||> map swap

    val rispec' = rispec
      |> map (apfst TVar)
      |> map (apfst (map_atyps (AList.lookup op= mapT #> the))) 
      |> map (apfst dest_TVar)

    val sbtspec_specs' = sbtspec_specs
      |> map (apfst (map_aterms (AList.lookup op= mapt #> the))) 
      |> map (apfst dest_Var)
      |> map (apfst (apsnd (map_atyps (AList.lookup op= mapT #> the))))

    val _ = verbose_writer_concl_thms etts_output_type ctxt' (single thm')

  in ((writer', rispec', sbtspec_specs'), thm') end;



(*** Substitution of type variables ***)
                                                                
fun etts_algorithm_subst_type ctxt' etts_output_type writer rispec thm =
  let
    val writer' = verbose_writer_prem 
      etts_output_type writer "substitution of type variables..."
    val thm' = 
      Drule.instantiate_normalize 
        (
          rispec 
          |> map (apsnd TFree) 
          |> map (apsnd (Thm.ctyp_of ctxt')), 
          []
        )
        thm
    val _ = verbose_writer_concl_thms etts_output_type ctxt' (single thm')
  in (writer', thm') end;



(*** Substitution of variables ***)

fun etts_algorithm_subst_var ctxt' etts_output_type writer sbtspec_specs thm =
  let
    val writer' = verbose_writer_prem 
      etts_output_type writer "substitution of variables..."
    val thm' = sbtspec_specs
      |> (Var #> (ctxt' |> Thm.cterm_of) |> apfst |> map)
      |> map Thm.first_order_match
      |> fold Drule.instantiate_normalize
      |> curry op|> thm
    val _ = verbose_writer_concl_thms etts_output_type  ctxt' (single thm')
  in (writer', thm') end;



(*** Untransfer ***)

fun etts_algorithm_untransfer ctxt' etts_output_type writer transfer_thms thm =
  let
    val writer' = verbose_writer_prem etts_output_type writer "untransfer..."
    val (thm', context) = Thm.apply_attribute
      (Transfer.untransferred_attribute transfer_thms) 
      thm 
      (Context.Proof ctxt')  
    val _ = verbose_writer_concl_thms etts_output_type ctxt' (single thm')
  in (context, writer', thm') end;



(*** Export ***)

fun etts_algorithm_export context ctxt etts_output_type writer thm =
  let
    val writer' = verbose_writer_prem etts_output_type writer "export..."
    val thy' = Context.theory_of context
    val ctxt' = Context.proof_of context
    val ctxt'' = Proof_Context.transfer thy' ctxt    
    val thm' = singleton (Proof_Context.export ctxt' ctxt'') thm
    val _ = verbose_writer_concl_thms etts_output_type ctxt'' (single thm')
  in ((writer', thm'), ctxt'') end;



(*** Cancel type definition ***)

fun etts_algorithm_ctd ctxt etts_output_type writer rispec thm =
  let
    val writer' = 
      verbose_writer_prem etts_output_type writer "cancel type definition..."
    val thm' = (rispec |> length |> cancel_type_definition_repeat) thm
    val _ = verbose_writer_concl_thms etts_output_type ctxt (single thm')
  in ((writer', thm'), ctxt) end;

in

fun etts_kera 
  ctxt 
  ctxt' 
  etts_output_type
  writer
  rispec 
  sbtspec_var_specs 
  sbtspec_const_specs 
  transfer_thms 
  thm =
  let
    val ((writer', rispec, sbtspec_var_specs, sbtspec_const_specs), thm') = 
      etts_algorithm_fresh_stv
        ctxt' 
        writer
        rispec 
        sbtspec_var_specs 
        sbtspec_const_specs 
        thm
    val ((writer'', sbtspec_specs), thm'') = 
      etts_algorithm_unfold_ud_with 
        ctxt' 
        etts_output_type 
        writer' 
        sbtspec_var_specs
        sbtspec_const_specs 
        thm'
    val ((writer''', rispec, sbtspec_specs'), thm''') = 
      etts_algorithm_unoverload_types 
        ctxt' etts_output_type writer'' rispec sbtspec_specs thm''
    val (writer'''', thm'''') = etts_algorithm_subst_type 
      ctxt' etts_output_type writer''' rispec thm'''
    val (writer''''', thm''''') = etts_algorithm_subst_var 
      ctxt' etts_output_type writer'''' sbtspec_specs' thm''''
    val (context, writer'''''', thm'''''') = etts_algorithm_untransfer 
      ctxt' etts_output_type writer''''' transfer_thms thm'''''
    val ((writer''''''', thm'''''''), ctxt'') = etts_algorithm_export 
      context ctxt etts_output_type writer'''''' thm''''''
    val ((writer'''''''', thm''''''''), ctxt''') = etts_algorithm_ctd 
      ctxt'' etts_output_type writer''''''' rispec thm'''''''
  in ((thm'''''''', writer''''''''), ctxt''') end;

end;




(**** Post-processing ****)

local



(*** Post-processing 1: simplification ***)

fun etts_algorithm_simplification ctxt etts_output_type writer sbrr_opt thm =
  let
    val writer = verbose_writer_prem etts_output_type writer "simplification..."
    val out_thm = More_Simplifier.rewrite_simp_opt' ctxt sbrr_opt thm
    val _ = verbose_writer_concl_thms etts_output_type ctxt (single out_thm)
  in (writer, out_thm) end;



(*** Post-processing 2: substitution of known premises ***)

local

(*ad-hoc application specific term equivalence*)
fun term_equiv_st (t, u) =
  let
    fun term_equiv_st ((Const (a, T)), (Const (b, U))) = 
          a = b andalso Type.could_match (T, U)
      | term_equiv_st ((Free (_, T)), (Free (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Var (_, T)), (Var (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Free (_, T)), (Var (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Var (_, T)), (Free (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Const (_, T)), (Free (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Free (_, T)), (Const (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Const (_, T)), (Var (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Var (_, T)), (Const (_, U))) = Type.could_match (T, U)
      | term_equiv_st ((Bound n), (Bound m)) = (n = m)
      | term_equiv_st ((Abs (_, T, t)), (Abs (_, U, u))) = 
          Type.could_match (T, U) andalso term_equiv_st (t, u)
      | term_equiv_st ((tl $ tr), (ul $ ur)) = 
          term_equiv_st (tl, ul) andalso term_equiv_st (tr, ur)
      | term_equiv_st ((Var (_, T)), (ul $ ur)) = 
          Type.could_match (T, type_of (ul $ ur))
      | term_equiv_st ((Var (_, T)), (Abs (c, U, u))) = 
          Type.could_match (T, type_of (Abs (c, U, u)))
      | term_equiv_st (_, _) = false;
  in 
    if 
      (Term.add_frees t [] |> null |> not) 
      andalso (Term.add_frees u [] |> null |> not) 
    then term_equiv_st (t, u)  
    else false
  end;

in

fun etts_algorithm_subst_prems ctxt etts_output_type writer subst_thms thm =
  let
    val writer' = verbose_writer_prem 
      etts_output_type writer "substitute known premises..."
    val thm' = 
      let 
        val subst_thms = Attrib.eval_thms ctxt subst_thms
        val subst_thmst = map Thm.full_prop_of subst_thms 
        fun option_thm thm_opt = case thm_opt of 
            SOME thm => thm 
          | _ => @{thm _}
        fun mk_OFthms ts = ts
          |> 
            (
              (subst_thmst ~~ subst_thms) 
              |> AList.lookup term_equiv_st 
              |> map
            )
          |> map option_thm
        fun subst_premises_repeat thm = 
          let
            val premsts = thm |> Thm.full_prop_of |> Logic.strip_imp_prems
            val out_thm = thm OF (mk_OFthms premsts)
          in 
            if Thm.nprems_of thm = Thm.nprems_of out_thm 
            then out_thm
            else subst_premises_repeat out_thm
          end
      in subst_premises_repeat thm end
    val _ = verbose_writer_concl_thms etts_output_type ctxt (single thm')
  in (writer', thm') end;

end;



(*** Post-processing 3: elimination of premises ***)

fun etts_algorithm_premred ctxt etts_output_type writer mpespc_opt thm =
  let
    val writer' = 
      verbose_writer_prem etts_output_type writer "elimination of premises..."
    val thm' = case mpespc_opt of 
        SOME m_spec => 
          let 
            val (out_thm, ctxt') = Thm.unvarify_local_thm ctxt thm
            val out_thm = out_thm 
              |> ETTS_Tactics.prem_red ctxt' m_spec 
              |> singleton (Proof_Context.export ctxt' ctxt) 
          in out_thm end
      | NONE => thm
    val _ = verbose_writer_concl_thms etts_output_type ctxt (single thm')
  in (writer', thm') end;



(*** Post-processing 4: application of the attributes ***)

fun etts_algorithm_app_attrb ctxt etts_output_type writer attrbs thm =
  let
    val writer' = verbose_writer_prem etts_output_type writer 
      "application of the attributes for the set-based theorem..."
    val (thm', ctxt') =
      let 
        val attrbs = 
          map (Attrib.check_src ctxt #> Attrib.attribute ctxt) attrbs
      in Thm.proof_attributes attrbs thm ctxt end
    val _ = verbose_writer_concl_thms etts_output_type ctxt' (single thm')
  in (writer', thm') end;

in

fun etts_algorithm_pp
  ctxt etts_output_type writer sbrr_opt subst_thms mpespc_opt attrbs thm =
  let
    val (writer', thm') = etts_algorithm_simplification 
      ctxt etts_output_type writer sbrr_opt thm
    val (writer'', thm'') = etts_algorithm_subst_prems 
      ctxt etts_output_type writer' subst_thms thm'
    val (writer''', thm''') = etts_algorithm_premred 
      ctxt etts_output_type writer'' mpespc_opt thm''
    val (writer'''', thm'''') = etts_algorithm_app_attrb 
      ctxt etts_output_type writer''' attrbs thm''' 
  in ((thm'''', writer''''), ctxt) end;

end;




(**** Extended relativization algorithm ****)

local

fun mk_msg_etts_algorithm msg = "tts_algorithm: " ^ msg;

fun etts_algorithm_input rispec thm =
  let

    val msg_etts_context = mk_msg_etts_algorithm
      "ERA can only be invoked from an appropriately parameterized tts context"
    val msg_ftvs = mk_msg_etts_algorithm
      "fixed type variables must not occur in the type-based theorems"
    val msg_fvs = mk_msg_etts_algorithm
      "fixed variables must not occur in the type-based theorems"
    val msg_not_risstv_subset = mk_msg_etts_algorithm
      "risstv must be a subset of the schematic type " ^
      "variables that occur in the type-based theorems"

    val _ = not (null rispec) orelse error msg_etts_context

    val t = Thm.full_prop_of thm
    val _ = t
      |> (fn t => Term.add_tfrees t [])
      |> null
      orelse error msg_ftvs 
    val _ = t
      |> (fn t => Term.add_frees t [])
      |> null
      orelse error msg_fvs 
    val stvs = t
      |> (fn t => Term.add_tvars t [])
      |> map #1
      |> distinct op=
    val risstv = map #1 rispec
    val _ = subset op= (risstv, stvs) orelse error msg_not_risstv_subset

  in () end;

in

fun etts_algorithm 
  ctxt 
  etts_output_type 
  writer
  rispec 
  sbtspec 
  sbrr_opt 
  subst_thms 
  mpespc_opt 
  attrbs 
  thm =
  let

    (*0. User input validation*)
    val _ = etts_algorithm_input rispec thm

    (*1. Initialization of the relativization context*)
    val 
      (
        ctxt,
        ctxt',
        writer,
        rispec,
        sbtspec_var_specs,
        sbtspec_const_specs,
        transfer_thms
      ) = init_rlt_ctxt ctxt etts_output_type writer rispec sbtspec

    (*2. Initialization of the relativization context*)
    val writer' = ETTS_Writer.increment_index 2 writer
    val ((thm', writer'), ctxt'') = etts_kera
      ctxt 
      ctxt' 
      etts_output_type
      writer'
      rispec 
      sbtspec_var_specs 
      sbtspec_const_specs 
      transfer_thms 
      thm

    (*3. Initialization of the relativization context*)
    val writer'' = ETTS_Writer.increment_index 2 writer'
    val ((thm'', writer'''), ctxt''') = etts_algorithm_pp
      ctxt'' etts_output_type writer'' sbrr_opt subst_thms mpespc_opt attrbs thm'

  in ((thm'', writer'''), ctxt''') end;

end;

fun etts_fact
  ctxt 
  etts_output_type 
  writer
  rispec 
  sbtspec 
  sbrr_opt 
  subst_thms 
  mpespc_opt 
  attrbs 
  thms =
  let
    fun folder thm ((thms, writer), ctxt) = 
      etts_algorithm
        ctxt
        etts_output_type
        writer
        rispec
        sbtspec 
        sbrr_opt 
        subst_thms 
        mpespc_opt 
        attrbs 
        thm
      |>> apsnd (ETTS_Writer.increment_index 1) 
      |>> apfst (curry (swap #> op::) thms)
  in fold_rev folder thms (([], writer), ctxt) end;

end;

File ‹ETTS_Active.ML›

(* Title: ETTS/ETTS_Active.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Active area output for Types-To-Sets.

Notes:
  - The structure ETTS_Active contains elements of code from the theory
  Sketch_and_Explore in the main library of Isabelle/HOL.
*)

signature ETTS_ACTIVE =
sig
val etts_indent : int Config.T
datatype etts_thm_type = 
  tts_lemma | tts_theorem | tts_corollary | tts_proposition
val theorem_string_of_term : 
  Proof.context ->
  etts_thm_type ->
  string ->
  Token.src list ->
  string -> 
  Token.src list -> 
  term -> 
  string
end;

structure ETTS_Active : ETTS_ACTIVE =
struct




(**** Indentation ****)

val etts_indent = Attrib.setup_config_int binding‹tts_indent› (K 2)

fun etts_indent_val ctxt = Config.get ctxt etts_indent

fun mk_etts_indent ctxt n = replicate (n*(etts_indent_val ctxt)) " " 
  |> String.concat




(**** Synonyms ****)

datatype etts_thm_type = 
  tts_lemma | tts_theorem | tts_corollary | tts_proposition;

fun string_of_etts_thm_type tts_lemma = "tts_lemma"
  | string_of_etts_thm_type tts_theorem = "tts_theorem"
  | string_of_etts_thm_type tts_corollary = "tts_corollary"
  | string_of_etts_thm_type tts_proposition = "tts_proposition";




(**** Auxiliary functions ported from Sketch_and_Explore ****)

(*ported from Sketch_and_Explore*)
fun maybe_quote ctxt =
  ATP_Util.maybe_quote (Thy_Header.get_keywords' ctxt);

(*ported from Sketch_and_Explore*)
fun print_term ctxt t = t
  |> Print_Mode.setmp [] (Syntax.unparse_term ctxt #> Pretty.string_of)
  |> Sledgehammer_Util.simplify_spaces
  |> maybe_quote ctxt;

(*ported from Sketch_and_Explore*)
fun mk_print_ctxt ctxt = fold
  (fn opt => Config.put opt false)
  [show_markup, Printer.show_type_emphasis, show_types, show_sorts, show_consts]
  ctxt;




(**** Further auxiliary functions ****)

(*create an assumption from a term represented by a string*)
fun mk_assumptions ctxt assmcs =
  let fun mk_eoln c = c ^ "\n"
  in 
    case assmcs of 
      [] => ""
    | assmcs => 
        mk_etts_indent ctxt 1 ^
        "assumes " ^ 
        String.concatWith ((mk_etts_indent ctxt 2) ^ "and ") (map mk_eoln assmcs)
  end;

(*unparsing attributes*)
fun mk_attr_string attrs = 
  if length attrs = 0 
  then ""
  else
    let
      val attrsc = attrs
        |> map (map Token.unparse) 
        |> map (String.concatWith " ")
        |> String.concatWith ", "
    in "[" ^ attrsc ^ "]" end

(*create a conclusion from a term represented by a string*)
fun mk_is ctxt thm_in_name attrs_in = 
  mk_etts_indent ctxt 2 ^ "is " ^ thm_in_name ^ mk_attr_string attrs_in

(*create conclusions*)
fun mk_shows ctxt thm_in_name attrs_in conclcs = case conclcs of
    [] => ""
  | conclcs => 
      mk_etts_indent ctxt 1 ^
      "shows " ^ 
      String.concatWith "\n" conclcs ^ "\n" ^
      mk_is ctxt thm_in_name attrs_in;

(*create a preamble*)
fun mk_preamble etts_thm_type thm_out_name attrs_out =
  (string_of_etts_thm_type etts_thm_type) ^ " " ^ 
  thm_out_name ^ 
  mk_attr_string attrs_out ^ ":\n"




(**** Conversion of theorems to strings for theory output ****)

fun theorem_string_of_term 
  ctxt etts_thm_type thm_out_name attrs_out thm_in_name attrs_in t =
  let
    val ctxt = mk_print_ctxt ctxt
    val t = t
      |> singleton (Syntax.uncheck_terms ctxt)
      |> Sledgehammer_Isar_Annotate.annotate_types_in_term ctxt
    val assmsc = t
      |> Logic.strip_imp_prems 
      |> map (print_term ctxt) 
      |> mk_assumptions ctxt
    val conclc = t
      |> Logic.strip_imp_concl
      |> Logic.dest_conjunctions
      |> map (print_term ctxt) 
      |> mk_shows ctxt thm_in_name attrs_in
    val preamblec = mk_preamble etts_thm_type thm_out_name attrs_out
    val done = ".\n\n"
    val thmc = String.concatWith "" [preamblec, assmsc, conclc, done]
  in thmc end;

end;

File ‹ETTS_Lemma.ML›

(* Title: ETTS/ETTS_Lemma.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the command tts_lemma.
*)

signature ETTS_LEMMA =
sig
val tts_lemma : Outer_Syntax.command_keyword -> string -> unit
end


structure ETTS_Lemma : ETTS_LEMMA =
struct




(**** Prerequisites ****)

open ETTS_Context;
open ETTS_Algorithm;




(**** Data for tts addendum ****)

datatype tts_addendum = tts_given | tts_is;

fun string_to_tts_addendum "given" = tts_given
  | string_to_tts_addendum "is" = tts_is
  | string_to_tts_addendum _ = error "string_to_tts_addendum: invalid input.";




(**** Tactics ****)

fun eq_thm_tac ctxt thm i = 
  let
    fun eq_thm_impl ctxt thm goal_thm =
      let
        val error_msg = "eq_thm_tac failed on " ^ (Thm.string_of_thm ctxt thm)
        val goal_prem_ct = goal_thm
          |> Thm.cprems_of 
          |> the_single
        val thm_ct = Thm.cprop_of thm
        val thm = thm
          |> Drule.instantiate_normalize (Thm.match (thm_ct, goal_prem_ct)) 
          |> Drule.eta_contraction_rule
          handle Pattern.MATCH => error error_msg
        val _ = ((Thm.full_prop_of thm) aconv (Thm.term_of goal_prem_ct))
          orelse error error_msg
      in Thm.implies_elim goal_thm thm end
  in SELECT_GOAL (PRIMITIVE (eq_thm_impl ctxt thm)) i end;

fun tts_lemma_tac ctxt (tts_given, thm) = Method.insert_tac ctxt (single thm)
  | tts_lemma_tac ctxt (tts_is, thm) = eq_thm_tac ctxt thm;

fun tts_lemma_map_tac ctxt tts_thm_spec = 
  let
    val tts_addendum_map = 
      AList.lookup op= (1 upto (length tts_thm_spec) ~~ tts_thm_spec) #> the                                  
    fun tac_map n = tts_lemma_tac ctxt (tts_addendum_map n) n
  in ALLGOALS tac_map end;

fun tts_lemma_map_method tts_thm_spec =
  let
    val method = CONTEXT_METHOD 
      (
        fn _ => fn (ctxt, st) => st 
          |> tts_lemma_map_tac ctxt tts_thm_spec 
          |> Context_Tactic.TACTIC_CONTEXT ctxt
      )
  in method end;

fun refine_tts_lemma_map thmss =
  Proof.refine_singleton (Method.Basic (K (tts_lemma_map_method thmss)));




(**** TTS algorithm interface ****)

fun relativization ctxt thms =
  let
    val 
      {
        mpespc_opt = mpespc_opt, 
        rispec = rispec, 
        sbtspec = sbtspec, 
        sbrr_opt = sbrr_opt,
        subst_thms = subst_thms, 
        attrbs = attrbs
      } = get_tts_ctxt_data ctxt
    val writer = ETTS_Writer.initialize 4
    val ((thms, _), _) = ETTS_Algorithm.etts_fact
      ctxt 
      default 
      writer
      rispec 
      sbtspec 
      sbrr_opt 
      subst_thms 
      mpespc_opt 
      attrbs 
      thms
  in thms end;

fun insert_rotate j thms =
  CONTEXT_METHOD 
    (
      fn _ => fn (ctxt, st) => st 
      |> ALLGOALS (fn i => Method.insert_tac ctxt thms i THEN rotate_tac j i) 
      |> Context_Tactic.TACTIC_CONTEXT ctxt
    );

fun refine_insert_rotate j ths =
  Proof.refine_singleton (Method.Basic (K (insert_rotate j ths)));

fun mk_tts_goal tts_thms_specs outer_ctxt st = 
  let

    (*pre-processing*)
    val tts_thms_specs = tts_thms_specs
      |> map
        (
          relativization outer_ctxt 
          |> apsnd 
          #> 
            (
              fn (tts_addendum, thms) => 
                (replicate (length thms) tts_addendum, thms)
            )
          #> op~~
        )
      |> flat
      |> map (apfst string_to_tts_addendum)
      
    (*create assumptions*)
    val ctxt = Proof.context_of st
    val assms = Assumption.local_prems_of ctxt outer_ctxt
    val all_ftv_permutes = assms
      |> map 
        (
          Thm.hyps_of 
          #> the_single 
          #> Logic.get_forall_ftv_permute 
          #> #2
          #> #2
        ) 
    val assms = map2 (Thm.forall_intr_var_order ctxt) all_ftv_permutes assms

    val st = refine_insert_rotate (~(length assms)) assms st

  in refine_tts_lemma_map tts_thms_specs st end;




(**** Parser ****)

(* 
The content of this section was adopted (with amendments) from the
theory Pure.thy.
*)
local

val long_keyword =
   Parse_Spec.includes >> K "" || Parse_Spec.long_statement_keyword;

val parse_tts_addendum = 
  keywordgiven -- Parse.thm || keywordis -- Parse.thm;

val parse_obtains = 
  Parse.$$$ "obtains" |-- Parse.!!! (Parse_Spec.obtains -- parse_tts_addendum);

fun process_obtains args = 
  (args |> #1 |> Element.Obtains, args |> #2 |> single);

val parse_shows = 
  let
    val statement = Parse.and_list1 
      (
        Parse_Spec.opt_thm_name ":" -- 
        Scan.repeat1 Parse.propp -- 
        parse_tts_addendum
      );
  in Parse.$$$ "shows" |-- Parse.!!! statement end;

fun process_shows args = (args |> map #1 |> Element.Shows, map #2 args);

val parse_long_statement = 
  Scan.optional 
    (Parse_Spec.opt_thm_name ":" --| Scan.ahead long_keyword) 
    Binding.empty_atts --
  Scan.optional Parse_Spec.includes [] -- 
    (
      Scan.repeat Parse_Spec.context_element -- 
      (parse_obtains >> process_obtains || parse_shows >> process_shows)
    );

fun process_long_statement 
  (((binding, includes), (elems, (concl, tts_thms_specs)))) = 
  (true, binding, includes, elems, concl, tts_thms_specs);

val long_statement = parse_long_statement >> process_long_statement;

val parse_short_statement = 
  Parse_Spec.statement -- 
  Parse_Spec.if_statement -- 
  Parse.for_fixes --
  parse_tts_addendum;

fun process_short_statement (((shows, assumes), fixes), tts_thms_specs) =
  (
    false, 
    Binding.empty_atts, 
    [], 
    [Element.Fixes fixes, Element.Assumes assumes],
    Element.Shows shows,
    single tts_thms_specs
  );

val short_statement = parse_short_statement >> process_short_statement;

in

val parse_tts_lemma = long_statement || short_statement;

end;




(**** Evaluation ****)

fun process_tts_lemma
  (long, binding, includes, elems, concl, tts_thms_specs) b lthy = 
  let
    val tts_thms_specs = 
      map (single #> Attrib.eval_thms lthy |> apsnd) tts_thms_specs
  in
    lthy
    |> Specification.theorem_cmd
      long Thm.theoremK NONE (K I) binding includes elems concl b
    |> mk_tts_goal tts_thms_specs lthy
  end;




(**** Interface ****)

fun tts_lemma spec descr = Outer_Syntax.local_theory_to_proof' 
  spec ("state " ^ descr) (parse_tts_lemma >> process_tts_lemma);

end;

File ‹ETTS_Lemmas.ML›

(* Title: ETTS/ETTS_Lemmas.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Implementation of the command tts_lemmas.
*)

signature TTS_LEMMAS =
sig
val tts_lemmas : 
  Proof.context ->
  ETTS_Algorithm.etts_output_type ->
  ((binding * Token.src list) * (thm list * (string * Token.src list))) list ->
  Proof.context * int list
end;


structure TTS_Lemmas : TTS_LEMMAS =
struct




(**** Prerequisites ****)

open ETTS_Algorithm;
open ETTS_Context;
open ETTS_Active;




(**** Implicit statement of theorems ****)

fun register_output ctxt ab out_thms = 
  let

    val ((thmc, out_thms), lthy) = 
      let 
        val facts' = (ab ||> map (Attrib.check_src ctxt), single (out_thms, []))
          |> single
          |> Attrib.partial_evaluation ctxt
      in ctxt |> Local_Theory.notes facts' |>> the_single end

    val _ = CTR_Utilities.thm_printer lthy true thmc out_thms

  in (lthy, "") end




(**** Output to an active area ****)

local

(*number of repeated premises*)
fun num_rep_prem eq ts = 
  let
    val premss = map Logic.strip_imp_prems ts    
    val min_length = min_list (map length premss)
    val premss = map (take min_length) premss
    val template_prems = hd premss
    val num_eq_prems = premss
      |> tl
      |> 
        map 
          (
            compare_each eq template_prems
            #> take_prefix (curry op= true)
            #> length
          )
    
    val num_rep_prems = 
      if length premss = 1 
      then length template_prems
      else min_list num_eq_prems
  in (num_rep_prems, premss) end;

(*elimination of premises*)
fun elim_assms assm_thms thm = fold (flip Thm.implies_elim) assm_thms thm;

(*create a single theorem from a fact via Pure conjunction*)
fun thm_of_fact ctxt thms =
  let
    
    val ts = map Thm.full_prop_of thms    

    val (num_rep_prems, _) = num_rep_prem (op aconv) ts

    val rep_prems = thms 
      |> hd 
      |> Thm.full_prop_of 
      |> Logic.strip_imp_prems 
      |> take num_rep_prems
      |> map (Thm.cterm_of ctxt);

    val all_ftv_rels = 
      let val subtract = swap #> uncurry (subtract op=)
      in 
        rep_prems
        |> map 
          (
            Thm.term_of 
            #> Logic.forall_elim_all 
            #> apfst (fn t => Term.add_frees t [])
            #> apsnd dup
            #> reroute_sp_ps  
            #> apfst (apfst dup)
            #> apfst reroute_ps_sp  
            #> apfst (apsnd subtract)
            #> apfst subtract
          )
        end

    val index_of_ftvs = all_ftv_rels 
      |> map 
        (
          #1
          #> map_index I
          #> map swap
          #> AList.lookup op=
          #> curry (swap #> op#>) the
        )

    val all_indicess = (map #2 all_ftv_rels) ~~ index_of_ftvs
      |> map (fn (x, f) => map f x)
    
    val (assms, ctxt') = Assumption.add_assumes rep_prems ctxt

    val stvss = 
      map 
        (
          Thm.full_prop_of 
          #> (fn t => Term.add_vars t [])
          #> map Var
          #> map (Thm.cterm_of ctxt)
        )
        assms
    
    val stvss = stvss ~~ all_indicess
      |> map (fn (stvs, indices) => map (nth stvs) indices)

    val assms = map2 forall_intr_list stvss assms
    
    val thm = thms 
      |> map (elim_assms assms)
      |> Conjunction.intr_balanced
      |> singleton (Proof_Context.goal_export ctxt' ctxt)

  in thm end;

in

(*output to an active area*)
fun active_output ctxt thm_out_name attrs_out thm_in_name attrs_in thms = 
  let
    val (thms, ctxt') = Thm.unvarify_local_fact ctxt thms
    val thmc = thms
      |> thm_of_fact ctxt' 
      |> Thm.full_prop_of
      |> theorem_string_of_term 
        ctxt tts_lemma thm_out_name attrs_out thm_in_name attrs_in
  in (ctxt, thmc) end;

end;




(**** Implementation ****)

fun tts_lemmas ctxt tts_output_type thm_specs =
  let

    val 
      {
        mpespc_opt = mpespc_opt, 
        rispec = rispec, 
        sbtspec = sbtspec, 
        sbrr_opt = sbrr_opt,
        subst_thms = subst_thms, 
        attrbs = attrbs
      } = get_tts_ctxt_data ctxt

    val writer = ETTS_Writer.initialize 4

    fun folder
      ((b, attrs_out), (thms, (thm_in_name, attrs_in))) (ctxt, thmcs, writer) =
      let
      
        val ((out_thms, writer), ctxt) = 
          ETTS_Algorithm.etts_fact 
            ctxt 
            tts_output_type 
            writer
            rispec 
            sbtspec 
            sbrr_opt 
            subst_thms 
            mpespc_opt 
            attrbs 
            thms
        
        val writer = ETTS_Writer.increment_index 0 writer
  
        val (lthy, thmc) = 
          if is_default tts_output_type orelse is_verbose tts_output_type
          then register_output ctxt (b, attrs_out) out_thms
          else 
            active_output 
              ctxt 
              (Name_Space.base_name b) 
              attrs_out 
              thm_in_name 
              attrs_in 
              out_thms

        val thmcs = thmcs ^ thmc
        
      in (lthy, thmcs, writer) end

    val (ctxt'', thmcs, writer) = fold folder thm_specs (ctxt, "", writer)

    val _ = 
      if is_active tts_output_type 
      then thmcs |> Active.sendback_markup_command |> writeln
      else () 

  in (ctxt'', writer) end;




(**** Parser ****)

local

val parse_output_mode = Scan.optional (keyword! || keyword?) "";
val parse_facts = keywordin |-- Parse_Spec.name_facts;

in

val parse_tts_lemmas = parse_output_mode -- parse_facts;

end;




(**** User input analysis ****)

fun mk_msg_tts_lemmas msg = "tts_lemmas: " ^ msg;

fun thm_specs_raw_input thm_specs_raw = 
  let
    val msg_multiple_facts = 
      mk_msg_tts_lemmas "only one fact per entry is allowed" 
    val _ = thm_specs_raw |> map (#2 #> length) |> List.all (fn n => n = 1)
      orelse error msg_multiple_facts
  in () end;




(**** Evaluation ****)

local

fun mk_thm_specs ctxt thm_specs_raw =
  let

    (*auxiliary functions*)

    fun binding_last c =
      let val binding_last_h = Long_Name.base_name #> Binding.qualified_name
      in if size c = 0 then Binding.empty else binding_last_h c end

    fun binding_of_binding_spec (b, (factb, thmbs)) =
      if Binding.is_empty b 
      then
        if length thmbs = 1 
        then
          if Binding.is_empty (the_single thmbs) 
          then factb
          else the_single thmbs
        else factb 
      else b

    (*main*)

    val thm_specs = thm_specs_raw
      |> map (apsnd the_single)
      |> 
        (
          Facts.ref_name 
          #> binding_last 
          |> apdupl 
          |> apfst
          #> reroute_ps_sp
          |> apsnd 
          |> map
        )
      |> map reroute_sp_ps
      |> map (reroute_ps_sp #> (swap |> apsnd) #> reroute_sp_ps |> apfst)  
      |> map (apsnd dup)
      |> 
        (
          single 
          #> (ctxt |> Attrib.eval_thms)
          #> (Thm.derivation_name #> binding_last |> map |> apdupl) 
          |> apfst
          |> apsnd 
          |> map
        )
      |> map (reroute_sp_ps #> apfst reroute_sp_ps #> reroute_ps_sp)
      |> 
        (
          reroute_ps_sp 
          #> (swap |> apsnd) 
          #> reroute_sp_ps 
          #> (reroute_ps_sp #> binding_of_binding_spec |> apfst) 
          |> apfst
          |> map
        )
      |> map (Facts.ref_name |> apfst |> apsnd |> apsnd)

  in thm_specs end;

in

fun process_tts_lemmas args ctxt =
  let
    (*unpacking*)
    val tts_output_type = args |> #1 |> etts_output_type_of_string
    val thm_specs_raw = #2 args 
    (*user input analysis*)
    val _ = thm_specs_raw_input thm_specs_raw
    (*pre-processing*)
    val thm_specs = mk_thm_specs ctxt thm_specs_raw
  in thm_specs |> tts_lemmas ctxt tts_output_type |> #1 end;

end;




(**** Interface ****)

val _ = Outer_Syntax.local_theory
  command_keywordtts_lemmas 
  "automated relativization of facts"
  (parse_tts_lemmas >> process_tts_lemmas);

end;

Theory ETTS_Auxiliary

(* Title: ETTS/ETTS_Auxiliary.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

Auxiliary functionality for the ETTS.
*)

section‹Auxiliary functionality and helpful lemmas for Types-To-Sets›
theory ETTS_Auxiliary
  imports ETTS
begin



subsection‹Further transfer rules›

lemma Domainp_eq[transfer_domain_rule, transfer_rule]: 
  "Domainp (=) = (λx. x  UNIV)"
  by auto

lemma Domainp_rel_prod[transfer_domain_rule, transfer_rule]:
  assumes "Domainp cr1 = (λx. x  𝔘1)" and "Domainp cr2 = (λx. x  𝔘2)"
  shows "Domainp (rel_prod cr1 cr2) = (λx. x  𝔘1 × 𝔘2)"
  using assms by (simp add: ctr_simps_pred_prod_eq_cart prod.Domainp_rel)



subsection‹Constant function›

definition const_fun :: "['b, 'a]  'b" where "const_fun c = (λx. c)"

lemma const_fun_transfer[transfer_rule]:
  includes lifting_syntax
  assumes "Domainp A = (λx. x  𝔘A)" and "x  𝔘A. f x = c" and "B c c'"
  shows "(A ===> B) f (const_fun c')"
proof(intro rel_funI)
  fix x y assume "A x y"
  then have "x  𝔘A" by (meson Domainp.DomainI assms(1))
  then have "f x = c" by (rule assms(2)[rule_format])
  show "B (f x) (const_fun c' y)" 
    unfolding f x = c const_fun_def by (rule assms(3))
qed



subsection‹Transfer rules suitable for instantiation›

lemma Domainp_eq_Collect: "Domainp A = (λx. x  𝔘) = (𝔘 = Collect (Domainp A))"
  by (metis mem_Collect_eq pred_equals_eq)

context
  includes lifting_syntax
begin

lemma tts_rel_set_transfer:
  fixes A :: "'al  'ar  bool"
    and B :: "'bl  'br  bool"
  assumes "S  Collect (Domainp A)" 
  shows "S'. rel_set A S S'"
  by (metis assms(1)[folded Ball_Collect] DomainpE Domainp_set)

lemma tts_AB_transfer:
  fixes f :: "'al  'bl"
    and A :: "'al  'ar  bool"
    and B :: "'bl  'br  bool"
  assumes closed: "f ` 𝔘A  𝔘B"
  assumes 
    "Domainp A = (λx. x  𝔘A)" "bi_unique A" "right_total A" 
    "Domainp B = (λx. x  𝔘B)" "bi_unique B" "right_total B" 
  shows "rcdt. (A ===> B) f rcdt"
proof-
  from closed have closed': "x  𝔘A  f x  𝔘B" for x by auto
  from assms(3,4) obtain Rep_a :: "'ar  'al" and Abs_a :: "'al  'ar" 
    where td_a: "type_definition Rep_a Abs_a (Collect (Domainp A))"
      and A_Rep: "A b b' = (b = Rep_a b')" for b b'
    by (blast dest: ex_type_definition)
  from assms(6,7) obtain Rep_b :: "'br  'bl" and Abs_b :: "'bl  'br" 
    where td_b: "type_definition Rep_b Abs_b (Collect (Domainp B))"
      and B_Rep: "B b b' = (b = Rep_b b')" for b b'
    by (blast dest: ex_type_definition)
  define f' where f': "f' = (Rep_a ---> Abs_b) f"  
  have f_closed: "f (Rep_a a)  𝔘B" for a 
    using td_a td_b by (intro closed') (simp add: assms(2,5))+
  have rep_abs_b: "y  𝔘B  y = Rep_b (Abs_b y)" for y
    using td_b unfolding type_definition_def by (simp add: assms(5))
  have "(A ===> B) f f'"
    unfolding f' map_fun_apply
    by 
      (
        intro rel_funI, 
        unfold A_Rep B_Rep,
        elim ssubst, 
        intro rep_abs_b f_closed
      )
  then show ?thesis by auto
qed

lemma tts_AB_transfer':
  fixes f' :: "'ar  'br"
    and A :: "'al  'ar  bool"
    and B :: "'bl  'br  bool"
  assumes 
    "Domainp A = (λx. x  𝔘A)" "bi_unique A" "right_total A" 
    "Domainp B = (λx. x  𝔘B)" "bi_unique B" "right_total B" 
  shows "f. (A ===> B) f f'"
proof-
  from assms(2,3) obtain Rep_a :: "'ar  'al" and Abs_a :: "'al  'ar" 
    where td_a: "type_definition Rep_a Abs_a (Collect (Domainp A))"
      and A_Rep: "A b b' = (b = Rep_a b')" for b b'
    by (blast dest: ex_type_definition)
  from assms(5,6) obtain Rep_b :: "'br  'bl" and Abs_b :: "'bl  'br" 
    where td_b: "type_definition Rep_b Abs_b (Collect (Domainp B))"
      and B_Rep: "B b b' = (b = Rep_b b')" for b b'
    by (blast dest: ex_type_definition)
  define f where f: "f = (Abs_a ---> Rep_b) f'"  
  have abs_rep_a: "y = Abs_a (Rep_a y)" for y
    using td_a unfolding type_definition_def by simp
  have "(A ===> B) f f'"
    unfolding f map_fun_apply
    by 
      (
        intro rel_funI, 
        unfold A_Rep B_Rep,
        elim ssubst, 
        fold abs_rep_a, 
        intro refl
      )
  then show ?thesis by auto
qed

lemma tts_AB_C_transfer: 
  fixes f :: "'al  'bl  'cl" 
    and A :: "'al  'ar  bool"
    and B :: "'bl  'br  bool"
    and C :: "'cl  'cr  bool" 
  assumes closed: "a b.  a  𝔘A; b  𝔘B   f a b  𝔘C"
  assumes 
    "Domainp A = (λx. x  𝔘A)" "bi_unique A" "right_total A" 
    "Domainp B = (λx. x  𝔘B)" "bi_unique B" "right_total B" 
    "Domainp C = (λx. x  𝔘C)" "bi_unique C" "right_total C"
  shows "rcdt. (A ===> B ===> C) f rcdt"
proof-
  from assms(3,4) obtain Rep_a :: "'ar  'al" and Abs_a :: "'al  'ar" 
    where td_a: "type_definition Rep_a Abs_a (Collect (Domainp A))"
      and A_Rep: "A b b' = (b = Rep_a b')" for b b'
    by (blast dest: ex_type_definition)
  from assms(6,7) obtain Rep_b :: "'br  'bl" and Abs_b :: "'bl  'br" 
    where td_b: "type_definition Rep_b Abs_b (Collect (Domainp B))"
      and B_Rep: "B b b' = (b = Rep_b b')" for b b'
    by (blast dest: ex_type_definition)
  from assms(9,10) obtain Rep_c :: "'cr  'cl" and Abs_c :: "'cl  'cr" 
    where td_c: "type_definition Rep_c Abs_c (Collect (Domainp C))"
      and C_Rep: "C b b' = (b = Rep_c b')" for b b'
    by (blast dest: ex_type_definition)
  define f' where f': "f' = (Rep_a ---> Rep_b ---> Abs_c) f"  
  from td_a td_b td_c have f_closed: "f (Rep_a a) (Rep_b b)  𝔘C" for a b
    by (intro closed; simp_all add: assms(2,5,8))+
  have rep_abs_c: "y  𝔘C  y = Rep_c (Abs_c y)" for y
    using td_c unfolding type_definition_def by (simp add: assms(8))
  have "(A ===> B ===> C) f f'"
    unfolding f' map_fun_apply
    by 
      (
        intro rel_funI, 
        unfold A_Rep B_Rep C_Rep,
        elim ssubst, 
        intro rep_abs_c f_closed
      )
  then show ?thesis by auto
qed

lemma tts_AA_A_transfer: 
  fixes A :: "'a  'b  bool" and f :: "'a  'a  'a"
  assumes closed: "a b.  a  𝔘; b  𝔘   f a b  𝔘"
  assumes "Domainp A = (λx. x  𝔘)" "bi_unique A" "right_total A" 
  shows "rcdt. (A ===> A ===> A) f rcdt"
  using closed 
  by (rule tts_AB_C_transfer[OF _ assms(2-4) assms(2-4) assms(2-4)])

lemma tts_AA_eq_transfer: 
  fixes A :: "'a  'b  bool" and f :: "'a  'a  bool"
  assumes "Domainp A = (λx. x  𝔘)" "bi_unique A" "right_total A" 
  shows "rcdt. (A ===> A ===> (=)) f rcdt"
proof-
  have closed: "f x y  UNIV" for x y by auto
  have dom_eq: "Domainp (=) = (λx. x  UNIV)" by auto
  from tts_AB_C_transfer[
      OF _ assms(1-3) assms(1-3) dom_eq bi_unique_eq right_total_eq
      ]
  show ?thesis by auto
qed

lemma Dom_fun_eq_set:
  assumes
    "Domainp A = (λx. x  𝔘A)" "bi_unique A" "right_total A" 
    "Domainp B = (λx. x  𝔘B)" "bi_unique B" "right_total B" 
  shows "{f. f ` 𝔘A  𝔘B} = Collect (Domainp (A ===> B))"
proof(standard; (standard, intro CollectI, elim CollectE DomainpE))
  fix x assume "x ` 𝔘A  𝔘B" 
  from tts_AB_transfer[OF this assms] obtain x' where xx': 
    "(A ===> B) x x'" by clarsimp
  show "Domainp (A ===> B) x" by standard (rule xx')
next
  fix x b assume "(A ===> B) x b" 
  then show "x ` 𝔘A  𝔘B"
    unfolding 
      rel_fun_def 
      Domainp_eq_Collect[THEN iffD1, OF assms(1)] 
      Domainp_eq_Collect[THEN iffD1, OF assms(4)] 
    by auto
qed

lemma Dom_AB_eq_pred: 
  assumes 
    "Domainp A = (λx. x  𝔘A)" "bi_unique A" "right_total A" 
    "Domainp B = (λx. x  𝔘B)" "bi_unique B" "right_total B" 
  shows "(Domainp (A ===> B) f) = (f ` 𝔘A  𝔘B)" 
  using Dom_fun_eq_set[OF assms] by blast

end

end

Theory Manual_Prerequisites

(* Title: ETTS/Manual/Manual_Prerequisites.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

section‹Prerequisites›
theory Manual_Prerequisites
  imports 
    "../ETTS"
    "HOL-Library.LaTeXsugar"
begin

ML_file ‹~~/src/Doc/antiquote_setup.ML›

(* Copied from Transfer.thy in the main library. *)
notation rel_fun (infixr "===>" 55)
notation map_fun (infixr "--->" 55)

type_notation bool (𝔹)

end

File ‹~~/src/Doc/antiquote_setup.ML›

(*  Title:      Doc/antiquote_setup.ML
    Author:     Makarius

Auxiliary antiquotations for the Isabelle manuals.
*)

structure Antiquote_Setup: sig end =
struct

(* misc utils *)

fun translate f = Symbol.explode #> map f #> implode;

val clean_string = translate
  (fn "_" => "\\_"
    | "#" => "\\#"
    | "$" => "\\$"
    | "%" => "\\%"
    | "<" => "$<$"
    | ">" => "$>$"
    | "{" => "\\{"
    | "|" => "$\\mid$"
    | "}" => "\\}"
    | "‐" => "-"
    | c => c);

fun clean_name "…" = "dots"
  | clean_name ".." = "ddot"
  | clean_name "." = "dot"
  | clean_name "_" = "underscore"
  | clean_name "{" = "braceleft"
  | clean_name "}" = "braceright"
  | clean_name s = s |> translate (fn "_" => "-" | "‐" => "-" | c => c);


(* ML text *)

local

fun ml_val (toks1, []) = ML_Lex.read "fn _ => (" @ toks1 @ ML_Lex.read ");"
  | ml_val (toks1, toks2) =
      ML_Lex.read "fn _ => (" @ toks1 @ ML_Lex.read " : " @ toks2 @ ML_Lex.read ");";

fun ml_op (toks1, []) = ML_Lex.read "fn _ => (op " @ toks1 @ ML_Lex.read ");"
  | ml_op (toks1, toks2) =
      ML_Lex.read "fn _ => (op " @ toks1 @ ML_Lex.read " : " @ toks2 @ ML_Lex.read ");";

fun ml_type (toks1, []) = ML_Lex.read "val _ = NONE : (" @ toks1 @ ML_Lex.read ") option;"
  | ml_type (toks1, toks2) =
      ML_Lex.read "val _ = [NONE : (" @ toks1 @ ML_Lex.read ") option, NONE : (" @
        toks2 @ ML_Lex.read ") option];";

fun ml_exception (toks1, []) = ML_Lex.read "fn _ => (" @ toks1 @ ML_Lex.read " : exn);"
  | ml_exception (toks1, toks2) =
      ML_Lex.read "fn _ => (" @ toks1 @ ML_Lex.read " : " @ toks2 @ ML_Lex.read " -> exn);";

fun ml_structure (toks, _) =
  ML_Lex.read "functor XXX() = struct structure XX = " @ toks @ ML_Lex.read " end;";

fun ml_functor (Antiquote.Text tok :: _, _) =
      ML_Lex.read "ML_Env.check_functor " @
      ML_Lex.read (ML_Syntax.print_string (ML_Lex.content_of tok))
  | ml_functor _ = raise Fail "Bad ML functor specification";

val is_name =
  ML_Lex.kind_of #> (fn kind => kind = ML_Lex.Ident orelse kind = ML_Lex.Long_Ident);

fun ml_name txt =
  (case filter is_name (ML_Lex.tokenize txt) of
    toks as [_] => ML_Lex.flatten toks
  | _ => error ("Single ML name expected in input: " ^ quote txt));

fun prep_ml source =
  (#1 (Input.source_content source), ML_Lex.read_source source);

fun index_ml name kind ml = Thy_Output.antiquotation_raw name
  (Scan.lift (Args.text_input -- Scan.option (Args.colon |-- Args.text_input)))
  (fn ctxt => fn (source1, opt_source2) =>
    let
      val (txt1, toks1) = prep_ml source1;
      val (txt2, toks2) =
        (case opt_source2 of
          SOME source => prep_ml source
        | NONE => ("", []));

      val txt =
        if txt2 = "" then txt1
        else if kind = "type" then txt1 ^ " = " ^ txt2
        else if kind = "exception" then txt1 ^ " of " ^ txt2
        else if Symbol_Pos.is_identifier (Long_Name.base_name (ml_name txt1))
        then txt1 ^ ": " ^ txt2
        else txt1 ^ " : " ^ txt2;
      val txt' = if kind = "" then txt else kind ^ " " ^ txt;

      val pos = Input.pos_of source1;
      val _ =
        ML_Context.eval_in (SOME ctxt) ML_Compiler.flags pos (ml (toks1, toks2))
          handle ERROR msg => error (msg ^ Position.here pos);
      val kind' = if kind = "" then "ML" else "ML " ^ kind;
    in
      Latex.block
       [Latex.string ("\\indexdef{}{" ^ kind' ^ "}{" ^ clean_string (ml_name txt1) ^ "}"),
        Thy_Output.verbatim ctxt txt']
    end);

in

val _ =
  Theory.setup
   (index_ml binding‹index_ML› "" ml_val #>
    index_ml binding‹index_ML_op› "infix" ml_op #>
    index_ml binding‹index_ML_type› "type" ml_type #>
    index_ml binding‹index_ML_exception› "exception" ml_exception #>
    index_ml binding‹index_ML_structure› "structure" ml_structure #>
    index_ml binding‹index_ML_functor› "functor" ml_functor);

end;


(* named theorems *)

val _ =
  Theory.setup (Thy_Output.antiquotation_raw binding‹named_thms›
    (Scan.repeat (Attrib.thm -- Scan.lift (Args.parens Args.name)))
    (fn ctxt =>
      map (fn (thm, name) =>
        Output.output
          (Document_Antiquotation.format ctxt
            (Document_Antiquotation.delimit ctxt (Thy_Output.pretty_thm ctxt thm))) ^
        enclose "\\rulename{" "}" (Output.output name))
      #> space_implode "\\par\\smallskip%\n"
      #> Latex.string #> single
      #> Thy_Output.isabelle ctxt));


(* Isabelle/Isar entities (with index) *)

local

fun no_check (_: Proof.context) (name, _: Position.T) = name;

fun check_keyword ctxt (name, pos) =
  if Keyword.is_keyword (Thy_Header.get_keywords' ctxt) name then name
  else error ("Bad outer syntax keyword " ^ quote name ^ Position.here pos);

fun check_system_option ctxt arg =
  (Completion.check_option (Options.default ()) ctxt arg; true)
    handle ERROR _ => false;

val arg = enclose "{" "}" o clean_string;

fun entity check markup binding index =
  Thy_Output.antiquotation_raw
    (binding |> Binding.map_name (fn name => name ^
      (case index of NONE => "" | SOME true => "_def" | SOME false => "_ref")))
    (Scan.lift (Scan.optional (Args.parens Args.name) "" -- Args.name_position))
    (fn ctxt => fn (logic, (name, pos)) =>
      let
        val kind = translate (fn "_" => " " | c => c) (Binding.name_of binding);
        val hyper_name =
          "{" ^ Long_Name.append kind (Long_Name.append logic (clean_name name)) ^ "}";
        val hyper =
          enclose ("\\hyperlink" ^ hyper_name ^ "{") "}" #>
          index = SOME true ? enclose ("\\hypertarget" ^ hyper_name ^ "{") "}";
        val idx =
          (case index of
            NONE => ""
          | SOME is_def =>
              "\\index" ^ (if is_def then "def" else "ref") ^ arg logic ^ arg kind ^ arg name);
        val _ =
          if Context_Position.is_reported ctxt pos then ignore (check ctxt (name, pos)) else ();
        val latex =
          idx ^
          (Output.output name
            |> (if markup = "" then I else enclose ("\\" ^ markup ^ "{") "}")
            |> hyper o enclose "\\mbox{\\isa{" "}}");
      in Latex.string latex end);

fun entity_antiqs check markup kind =
  entity check markup kind NONE #>
  entity check markup kind (SOME true) #>
  entity check markup kind (SOME false);

in

val _ =
  Theory.setup
   (entity_antiqs no_check "" binding‹syntax› #>
    entity_antiqs Outer_Syntax.check_command "isacommand" binding‹command› #>
    entity_antiqs check_keyword "isakeyword" binding‹keyword› #>
    entity_antiqs check_keyword "isakeyword" binding‹element› #>
    entity_antiqs Method.check_name "" binding‹method› #>
    entity_antiqs Attrib.check_name "" binding‹attribute› #>
    entity_antiqs no_check "" binding‹fact› #>
    entity_antiqs no_check "" binding‹variable› #>
    entity_antiqs no_check "" binding‹case› #>
    entity_antiqs Document_Antiquotation.check "" binding‹antiquotation› #>
    entity_antiqs Document_Antiquotation.check_option "" binding‹antiquotation_option› #>
    entity_antiqs Document_Marker.check "" binding‹document_marker› #>
    entity_antiqs no_check "isasystem" binding‹setting› #>
    entity_antiqs check_system_option "isasystem" binding‹system_option› #>
    entity_antiqs no_check "" binding‹inference› #>
    entity_antiqs no_check "isasystem" binding‹executable› #>
    entity_antiqs Isabelle_Tool.check "isatool" binding‹tool› #>
    entity_antiqs ML_Context.check_antiquotation "" binding‹ML_antiquotation› #>
    entity_antiqs (K JEdit.check_action) "isasystem" binding‹action›);

end;

end;

Theory ETTS_Tests

(* Title: ETTS/Tests/ETTS_Tests.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins

A test suite for the ETTS.
*)

section‹A test suite for ETTS›
theory ETTS_Tests
  imports
    "../ETTS_Auxiliary"
    Conditional_Transfer_Rule.IML_UT
begin



subsectionamend_ctxt_data›

ML_file‹ETTS_TEST_AMEND_CTXT_DATA.ML›

locale test_amend_ctxt_data =
  fixes UA :: "'ao set" and UB :: "'bo set" and UC :: "'co set"
    and le :: "['ao, 'ao]  bool" (infix ow 50) 
    and ls :: "['bo, 'bo]  bool" (infix <ow 50)
    and f :: "['ao, 'bo]  'co"
  assumes closed_f: "a  UA  b  UB  f a b  UC"
begin

notation le ('(≤ow'))
  and le (infix ow 50) 
  and ls ('(<ow')) 
  and ls (infix <ow 50)

tts_register_sbts (≤ow) | UA
proof-
  assume "Domainp AOA = (λx. x  UA)" "bi_unique AOA" "right_total AOA" 
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts (<ow) | UB
proof-
  assume "Domainp BOA = (λx. x  UB)" "bi_unique BOA" "right_total BOA"
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts f | UA and UB and UC
proof-
  assume 
    "Domainp AOC = (λx. x  UA)" "bi_unique AOC" "right_total AOC"
    "Domainp BOB = (λx. x  UB)" "bi_unique BOB" "right_total BOB"
    "Domainp COA = (λx. x  UC)" "bi_unique COA" "right_total COA"
  from tts_AB_C_transfer[OF closed_f this] show ?thesis by auto
qed

end

context test_amend_ctxt_data
begin

MLval tts_test_amend_ctxt_data_test_results =
  etts_test_amend_ctxt_data.execute_test_suite_amend_context_data @{context}
MLval _ = tts_test_amend_ctxt_data_test_results
  |> UT_Test_Suite.output_test_results true
›

end



subsectiontts_algorithm›


text‹
Some of the elements of the content of this section are based on the 
elements of the content of \cite{cain_nine_2019}. 
›

(*the following theorem is restated for forward compatibility*)
lemma exI': "P x  x. P x" by auto

class tta_mult =
  fixes tta_mult :: "'a  'a  'a" (infixl "*tta" 65)

class tta_semigroup = tta_mult +
  assumes tta_assoc[simp]: "(a *tta b) *tta c = a *tta (b *tta c)"

definition set_mult :: "'a::tta_mult set  'a set  'a set" (infixl "*tta" 65) 
  where "set_mult S T = {s *tta t | s t. s  S  t  T}"

definition left_ideal :: "'a::tta_mult set  bool"
  where "left_ideal T  (s. tT. s *tta t  T)"

lemma left_idealI[intro]:
  assumes "s t. t  T  s *tta t  T"
  shows "left_ideal T"
  using assms unfolding left_ideal_def by simp

lemma left_idealE[elim]:
  assumes "left_ideal T"
  obtains "s t. t  T  s *tta t  T"
  using assms unfolding left_ideal_def by simp

lemma left_ideal_set_mult_iff: "left_ideal T  UNIV *tta T  T"
  unfolding left_ideal_def set_mult_def by auto

ud ‹set_mult› 
ud ‹left_ideal›

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "bi_unique A" "right_total A" 
  trp (?'a A)
  in set_mult_ow: set_mult.with_def 
    and left_ideal_ow: left_ideal.with_def 

locale tta_semigroup_hom =
  fixes f :: "'a::tta_semigroup  'b::tta_semigroup"
  assumes hom: "f (a *tta b) = f a *tta f b"

context tta_semigroup_hom
begin

lemma tta_left_ideal_closed:
  assumes "left_ideal T" and "surj f"
  shows "left_ideal (f ` T)"
  unfolding left_ideal_def
proof(intro allI ballI)
  fix fs ft assume prems: "ft  f ` T"
  then obtain t where t: "t  T" and ft_def: "ft = f t" by clarsimp
  from assms(2) obtain s where fs_def: "fs = f s" by auto
  from assms have "t  T  s *tta t  T" for s t by auto
  with t show "fs *tta ft  f ` T" 
    unfolding ft_def fs_def hom[symmetric] by simp
qed

end

locale semigroup_mult_hom_with = 
  dom: tta_semigroup times_a + cod: tta_semigroup times_b
  for times_a (infixl *ow.a 70) and times_b (infixl *ow.b 70) +
  fixes f :: "'a  'b"
  assumes f_hom: "f (a *ow.a b) = f a *ow.b f b"

lemma semigroup_mult_hom_with[ud_with]:
  "tta_semigroup_hom = semigroup_mult_hom_with (*tta) (*tta)"
  unfolding 
    semigroup_mult_hom_with_def tta_semigroup_hom_def 
    class.tta_semigroup_def semigroup_mult_hom_with_axioms_def
  by auto

locale semigroup_ow = 
  fixes U :: "'ag set" and f :: "['ag, 'ag]  'ag" (infixl *ow 70)
  assumes f_closed: " a  U; b  U   a *ow b  U"
    and assoc: " a  U; b  U; c  U   a *ow b *ow c = a *ow (b *ow c)"
begin

notation f (infixl *ow 70)

lemma f_closed'[simp]: "xU. yU. x *ow y  U" by (simp add: f_closed)

tts_register_sbts (*ow) | U by (rule tts_AA_A_transfer[OF f_closed])

end

locale times_ow =
  fixes U :: "'ag set" and times :: "['ag, 'ag]  'ag" (infixl *ow 70)
  assumes times_closed[simp, intro]: " a  U; b  U   a *ow b  U"
begin

notation times (infixl *ow 70)

lemma times_closed'[simp]: "xU. yU. x *ow y  U" by simp

tts_register_sbts (*ow) | U  by (rule tts_AA_A_transfer[OF times_closed])

end

locale semigroup_mult_ow = times_ow U times 
  for U :: "'ag set" and times +
  assumes mult_assoc: 
    " a  U; b  U; c  U   a *ow b *ow c = a *ow (b *ow c)"
begin

sublocale mult: semigroup_ow U (*ow) 
  by unfold_locales (auto simp: times_closed' mult_assoc)

end

locale semigroup_mult_hom_ow = 
  dom: semigroup_mult_ow UA times_a + 
  cod: semigroup_mult_ow UB times_b 
  for UA :: "'a set" 
    and UB :: "'b set" 
    and times_a (infixl *ow.a 70) 
    and times_b (infixl *ow.b 70) +
  fixes f :: "'a  'b"
  assumes f_closed[simp]: "a  UA  f a  UB"
    and f_hom: " a  UA; b  UA   f (a *ow.a b) = f a *ow.b f b"
begin

lemma f_closed'[simp]: "f ` UA  UB" by auto

tts_register_sbts f | UA and UB by (rule tts_AB_transfer[OF f_closed'])

end

context semigroup_mult_hom_ow
begin

lemma tta_left_ideal_ow_closed:
  assumes "T  UA"
    and "left_ideal_ow UA (*ow.a) T"
    and "f ` UA = UB"
  shows "left_ideal_ow UB (*ow.b) (f ` T)"
  unfolding left_ideal_ow_def
proof(intro ballI)
  fix fs ft assume ft: "ft  f ` T" and fs: "fs  UB"
  then obtain t where t: "t  T" and ft_def: "ft = f t" by auto
  from assms(3) fs obtain s where fs_def: "fs = f s" and s: "s  UA" by auto
  from assms have " s  UA; t  T   s *ow.a t  T" for s t 
    unfolding left_ideal_ow_def by simp
  with assms(1) s t fs show "fs *ow.b ft  f ` T" 
    using f_hom[symmetric, OF s] unfolding ft_def fs_def by auto
qed

end

lemma semigroup_mult_ow: "class.tta_semigroup = semigroup_mult_ow UNIV"
  unfolding 
    class.tta_semigroup_def semigroup_mult_ow_def
    semigroup_mult_ow_axioms_def times_ow_def
  by simp

lemma semigroup_mult_hom_ow: 
  "tta_semigroup_hom = semigroup_mult_hom_ow UNIV UNIV (*tta) (*tta)"
  unfolding 
    tta_semigroup_hom_def semigroup_mult_hom_ow_axioms_def
    semigroup_mult_hom_ow_def semigroup_mult_ow_def 
    semigroup_mult_ow_axioms_def times_ow_def
  by simp

context
  includes lifting_syntax
begin

lemma semigroup_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=))
      (semigroup_ow (Collect (Domainp A))) semigroup"
proof-
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_ow = "semigroup_ow (Collect (Domainp A))"
  let ?rf_UNIV = 
    "(λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))"
  have "?P ?semigroup_ow (λf. ?rf_UNIV f  semigroup f)"
    unfolding semigroup_ow_def semigroup_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows
    "((A ===> A ===> A) ===> (=))
      (semigroup_mult_ow (Collect (Domainp A)))
      class.tta_semigroup"
proof -
  let ?P = ((A ===> A ===> A) ===> (=))
    and ?semigroup_mult_ow = 
      (λf. semigroup_mult_ow (Collect (Domainp A)) f)
    and ?rf_UNIV = 
      (λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))
  have "?P ?semigroup_mult_ow (λf. ?rf_UNIV f  class.tta_semigroup f)"
    unfolding 
      semigroup_mult_ow_def class.tta_semigroup_def
      semigroup_mult_ow_axioms_def times_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_mult_hom_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B" 
  shows
    "((A ===> A ===> A) ===> (B ===> B ===> B) ===> (A ===> B) ===> (=))
      (semigroup_mult_hom_ow (Collect (Domainp A)) (Collect (Domainp B)))
      semigroup_mult_hom_with"
proof-
  let ?PA = "A ===> A ===> A"
    and ?PB = "B ===> B ===> B"
    and ?semigroup_mult_hom_ow = 
      λtimes_a times_b f. semigroup_mult_hom_ow 
          (Collect (Domainp A)) (Collect (Domainp B)) times_a times_b f
  let ?closed = λf::'b'd . a. a  UNIV  f a  UNIV›
  have
    "(?PA ===> ?PB ===> (A ===> B) ===> (=))
      ?semigroup_mult_hom_ow
      (
        λtimes_a times_b f. 
          ?closed f  semigroup_mult_hom_with times_a times_b f
      )"
    unfolding 
      times_ow_def
      semigroup_mult_hom_ow_def 
      semigroup_mult_hom_ow_axioms_def 
      semigroup_mult_hom_with_def
      semigroup_mult_hom_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

end

context semigroup_mult_hom_ow
begin

ML_file‹ETTS_TEST_TTS_ALGORITHM.ML›

named_theorems semigroup_mult_hom_ow_test_simps

lemmas [semigroup_mult_hom_ow_test_simps] = 
  ctr_simps_Collect_mem_eq
  ctr_simps_in_iff

tts_context
  tts: (?'a to UA) and (?'b to UB)
  sbterms: ((*tta)::[?'a::tta_semigroup, ?'a]  ?'a to (*ow.a))
    and ((*tta)::[?'b::tta_semigroup, ?'b]  ?'b to (*ow.b))
    and (?f::?'a::tta_semigroup  ?'b::tta_semigroup› to f)
  rewriting semigroup_mult_hom_ow_test_simps
  substituting semigroup_mult_hom_ow_axioms
    and dom.semigroup_mult_ow_axioms
    and cod.semigroup_mult_ow_axioms
  eliminating UA  {} and UB  {} 
    through (auto simp only: left_ideal_ow_def)
begin

MLval tts_test_amend_ctxt_data_test_results =
  etts_test_tts_algorithm.execute_test_suite_tts_algorithm @{context}
MLval _ = tts_test_amend_ctxt_data_test_results
  |> UT_Test_Suite.output_test_results true
›

end

end



subsectiontts_register_sbts›

context 
  fixes f :: "'a  'b  'c"
    and UA :: "'a set"
begin

ML_file‹ETTS_TEST_TTS_REGISTER_SBTS.ML›
MLval tts_test_tts_register_sbts_test_results =
  etts_test_tts_register_sbts.execute_test_suite_tts_register_sbts @{context}
MLval _ = tts_test_tts_register_sbts_test_results
  |> UT_Test_Suite.output_test_results true
›

end

end

File ‹ETTS_TEST_AMEND_CTXT_DATA.ML›

(* Title: ETTS/Tests/ETTS_TEST_AMEND_CTXT_DATA.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

signature ETTS_TEST_AMEND_CTXT_DATA =
sig

val execute_test_suite_amend_context_data : 
  Proof.context -> 
  (
    ETTS_Context.amend_ctxt_data_input_type * Proof.context, 
    ETTS_Context.ctxt_def_type * Proof.context
  ) UT_Test_Suite.test_results_suite

end;

structure etts_test_amend_ctxt_data : ETTS_TEST_AMEND_CTXT_DATA =
struct



(**** Auxiliary ****)

fun mk_msg_tts_ctxt_error msg = "tts_context: " ^ msg

(* 
approximate comparison of Token.src values: should not be made public
and should be used with great care 
*)
local

val eq_eps_src_msg = "eq_eps_src: comparison is not possible"

in

fun eq_eps_src (src, src') = 
  let
    val eq_name = Token.name_of_src src = Token.name_of_src src'
    val eq_args = Token.args_of_src src ~~ Token.args_of_src src'
      |> map eq_eps_token
      |> List.all I
  in eq_name andalso eq_args end
and eq_eps_token (token : Token.T, token' : Token.T) =
  let
    val eq_kind = Token.kind_of token = Token.kind_of token'
    val eq_content = Token.content_of token = Token.content_of token'
    val eq_source = Token.source_of token = Token.source_of token'
    val eq_range =
      Input.range_of (Token.input_of token) = 
      Input.range_of (Token.input_of token')
    val eq_slot = (Token.get_value token, Token.get_value token')
      |> eq_option eq_eps_value
  in 
    eq_kind
    andalso eq_content 
    andalso eq_source 
    andalso eq_range
    andalso eq_slot
  end
and eq_eps_value (Token.Source src, Token.Source src') = eq_eps_src (src, src')
  | eq_eps_value (Token.Literal ltrl, Token.Literal ltrl') = ltrl = ltrl'
  | eq_eps_value (Token.Name _, Token.Name _) = error eq_eps_src_msg 
  | eq_eps_value (Token.Typ T, Token.Typ T') = T = T'
  | eq_eps_value (Token.Term t, Token.Term t') = t = t'
  | eq_eps_value (Token.Fact (c_opt, thms), Token.Fact (c_opt', thms')) = 
      let
        val eq_c = c_opt = c_opt' 
        val eq_thms = eq_list Thm.eq_thm (thms, thms')
      in eq_c andalso eq_thms end
  | eq_eps_value (Token.Attribute _, Token.Attribute _) = 
      error eq_eps_src_msg
  | eq_eps_value (Token.Declaration _, Token.Declaration _) = 
      error eq_eps_src_msg
  | eq_eps_value (Token.Files _, Token.Files _) = 
      error eq_eps_src_msg;

end;

(* 
approximate comparison of ctxt_def_type: should not be made public
and used with great care 
*)
fun eq_tts_ctxt_data
  (
    ctxt_data : ETTS_Context.ctxt_def_type, 
    ctxt_data' : ETTS_Context.ctxt_def_type
  ) = 
  let
    fun eq_subst_thm (rsrc, rsrc') = fst rsrc = fst rsrc' 
      andalso eq_list eq_eps_src (snd rsrc, snd rsrc') 
    val _ = (#mpespc_opt ctxt_data, #mpespc_opt ctxt_data')
      |> apply2 is_none
      |> (fn (x, y) => x = true andalso y = true)
      orelse error "eq_tts_ctxt_data: comparison is not possible"
    val eq_rispec = #rispec ctxt_data = #rispec ctxt_data'
    val eq_sbtspec = #sbtspec ctxt_data = #sbtspec ctxt_data'
    val eq_subst_thms = 
      eq_list eq_subst_thm (#subst_thms ctxt_data, #subst_thms ctxt_data')
    val eq_sbrr_opt = (#sbrr_opt ctxt_data, #sbrr_opt ctxt_data')
      |> eq_option eq_subst_thm
    val eq_attrbs = eq_list eq_eps_src (#attrbs ctxt_data, #attrbs ctxt_data')
  in 
    eq_rispec 
    andalso eq_sbtspec
    andalso eq_subst_thms
    andalso eq_sbrr_opt
    andalso eq_attrbs
  end;




(**** Tests ****)



(*** Valid inputs ***)

fun test_eq_tts_context (ctxt : Proof.context) = 
  let
    
    (*input*)
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val risstv2_c = "?'b"
    val U2_c = "UB::'bo set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val tbt_1 = "(≤)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(≤ow)"
    val tbt_2 = "(<)::?'b::ord⇒?'b::ord⇒bool"
    val sbt_2 = "(<ow)"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args : ETTS_Context.amend_ctxt_data_input_type = 
      (((((rispec, sbtspec), NONE), []), NONE), [])
    
    (*output*)
    val s_a_ix : indexname = ("'a", 0)
    val s_a_T = TVar (s_a_ix, sort‹ord›)
    val aT = TFree ("'ao", sort‹type›)
    val U1 = Free ("UA", HOLogic.mk_setT aT)
    val s_b_ix : indexname = ("'b", 0)
    val s_b_T = TVar (s_b_ix, sort‹ord›)
    val bT = TFree ("'bo", sort‹type›)
    val U2 = Free ("UB", HOLogic.mk_setT bT)
    
    val less_eqt = 
      Const (const_name‹less_eq›, s_a_T --> s_a_T --> HOLogic.boolT)
    val lesst = 
      Const (const_name‹less›, s_b_T --> s_b_T --> HOLogic.boolT)
    val leqt = Free ("le", aT --> aT --> HOLogic.boolT)
    val lst = Free ("ls", bT --> bT --> HOLogic.boolT)
 
    val rispec = [(s_a_ix, U1), (s_b_ix, U2)]
    val sbtspec = [(less_eqt, leqt), (lesst, lst)]
    val subst_thms = []
    val sbrr_opt = NONE
    val mpespc_opt = NONE
    val attrbs = []

    val tts_ctxt_data_out : ETTS_Context.ctxt_def_type = 
      {
        rispec = rispec,
        sbtspec = sbtspec,
        subst_thms = subst_thms,
        sbrr_opt = sbrr_opt,
        mpespc_opt = mpespc_opt,
        attrbs = attrbs
      }

  in
    UT_Test_Suite.assert_brel 
      "equality"
      (eq_fst eq_tts_ctxt_data) 
      (tts_ctxt_data_out, ctxt)
      (args, ctxt)
  end;



(*** Exceptions ***)


(** General **)

fun test_exc_tts_context_tts_context thy = 
  let

    val ctxt = Proof_Context.init_global thy;

    val risstv1_c = "?'a"
    val U1_c = "U1::'a set"
    val rispec1 = [(risstv1_c, U1_c)]
    val args1 : ETTS_Context.amend_ctxt_data_input_type = 
      (((((rispec1, []), NONE), []), NONE), [])
    val ctxt' = ETTS_Context.amend_context_data args1 ctxt |> snd

    val risstv2_c = "?'b"
    val U2_c = "U2::'b set"
    val rispec2 = [(risstv2_c, U2_c)]
    val args2 : ETTS_Context.amend_ctxt_data_input_type = 
      (((((rispec2, []), NONE), []), NONE), [])

    val err_msg = mk_msg_tts_ctxt_error "nested tts contexts"

  in 
    UT_Test_Suite.assert_exception 
      "nested tts contexts" (args2, ctxt') (ERROR err_msg)
  end;


(** tts **)

fun test_exc_rispec_empty thy = 
  let 
    val ctxt = Proof_Context.init_global thy;
    val args = ((((([], []), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error "rispec must not be empty"
  in 
    UT_Test_Suite.assert_exception "rispec empty" (args, ctxt) (ERROR err_msg)
  end;

fun test_exc_rispec_not_set thy = 
  let 
    val ctxt = Proof_Context.init_global thy;
    val risstv1_c = "?'a"
    val U1_c = "U1::('b list) set"
    val risstv2_c = "?'b"
    val U2_c = "U2::'a set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val args = (((((rispec, []), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error 
      "risset must be terms of the type of the form ?'a set or 'a set"
  in 
    UT_Test_Suite.assert_exception 
      "risset are not all sets" (args, ctxt) (ERROR err_msg)
  end;

fun test_exc_rispec_duplicate_risstvs thy = 
  let 
    val ctxt = Proof_Context.init_global thy;
    val risstv1_c = "?'a"
    val U1_c = "U1::'a set"
    val risstv2_c = "?'b"
    val U2_c = "U2::'b set"
    val risstv3_c = "?'a"
    val U3_c = "U3::'c set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c), (risstv3_c, U3_c)]
    val args = (((((rispec, []), NONE), []), NONE), [])
  in
    UT_Test_Suite.assert_exception
      "duplicate risstvs"
      (args, ctxt)
      (ERROR "tts_context: risstvs must be distinct")
  end;

fun test_exc_rispec_not_ds_dtv thy = 
  let 
    val ctxt = Proof_Context.init_global thy;
    val risstv1_c = "?'a"
    val U1_c = "U1::'a set"
    val risstv2_c = "?'b"
    val U2_c = "U2::'b::{group_add, finite} set"
    val risstv3_c = "?'c"
    val U3_c = "U3::'c::{group_add, order} set"
    val risstv4_c = "?'d"
    val U4_c = "U4::'b::{group_add, order} set"
    val rispec = 
      [(risstv1_c, U1_c), (risstv2_c, U2_c), (risstv3_c, U3_c), (risstv4_c, U4_c)]
    val args = (((((rispec, []), NONE), []), NONE), [])
    val err_msg = 
      "tts_context: risset: type variables with distinct sorts must be distinct"
  in
    UT_Test_Suite.assert_exception
      "not distinct sorts ⟶ distinct types variables" 
      (args, ctxt) 
      (ERROR err_msg)
  end;

fun test_exc_rispec_not_dt_dv thy = 
  let 
    val ctxt = Proof_Context.init_global thy;
    val risstv1_c = "?'a"
    val U1_c = "U1::'a set"
    val risstv2_c = "?'b"
    val U2_c = "U2::'b::{group_add, finite} set"
    val risstv3_c = "?'c"
    val U3_c = "U3::'c::{group_add, order} set"
    val risstv4_c = "?'d"
    val U4_c = "U2::'c::{group_add, order} set"
    val rispec = 
      [
        (risstv1_c, U1_c), 
        (risstv2_c, U2_c), 
        (risstv3_c, U3_c), 
        (risstv4_c, U4_c)
      ]
    val args = (((((rispec, []), NONE), []), NONE), [])
    val err_msg = 
      "tts_context: risset: variables with distinct types must be distinct"
  in
    UT_Test_Suite.assert_exception
      "not distinct types ⟶ distinct variables" (args, ctxt) (ERROR err_msg)
  end;


(** sbterms **)

fun test_exc_distinct_sorts ctxt = 
  let 
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val risstv2_c = "?'b"
    val U2_c = "UB::'bo set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val tbt_1 = "(<)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(<ow)"
    val tbt_2 = "?a::?'a::order⇒?'a::order⇒bool"
    val sbt_2 = "f"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args = (((((rispec, sbtspec), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error 
      "tbts: a single stv should not have two distinct sorts associated with it"
  in 
    UT_Test_Suite.assert_exception 
      "tbts: an stv with distinct sorts" (args, ctxt) (ERROR err_msg)
  end;

fun test_exc_sbts_no_tis ctxt = 
  let 
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val risstv2_c = "?'b"
    val U2_c = "UB::'bo set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val tbt_1 = "(<)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(<ow)"
    val tbt_2 = "(≤)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_2 = "(≤ow)"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args = (((((rispec, sbtspec), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error 
      "\n\t-the types of the sbts must be equivalent " ^ 
      "to the types of the tbts up to renaming of the type variables\n" ^
      "\t-to each type variable that occurs among the tbts must correspond " ^ 
      "exactly one type variable among all type " ^
      "variables that occur among all of the sbts"
  in 
    UT_Test_Suite.assert_exception 
      "sbts are not type instances of tbts" (args, ctxt) (ERROR err_msg)
  end;

fun test_exc_tbt_fixed ctxt = 
  let 
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val risstv2_c = "?'b"
    val U2_c = "UB::'bo set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val tbt_1 = "(<)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(<ow)"
    val tbt_2 = "g::?'a::ord⇒?'a::ord⇒bool"
    val sbt_2 = "(<ow)"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args = (((((rispec, sbtspec), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error 
      "tbts must consist of constants and schematic variables"
  in 
    UT_Test_Suite.assert_exception 
      "tbts are not constants and schematic variables" 
      (args, ctxt) 
      (ERROR err_msg)
  end;

fun test_exc_sbts_not_registered ctxt = 
  let 
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val risstv2_c = "?'b"
    val U2_c = "UB::'bo set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val tbt_1 = "(<)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(<ow)"
    val tbt_2 = "(≤)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_2 = "g::'bo::type⇒'bo::type⇒bool"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args = (((((rispec, sbtspec), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error
      "sbts must be registered using the command tts_register_sbts"
  in
    UT_Test_Suite.assert_exception
      "sbts must be registered" (args, ctxt) (ERROR err_msg)
  end;

fun test_exc_tbts_not_distinct ctxt = 
  let 
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val risstv2_c = "?'b"
    val U2_c = "UB::'bo set"
    val rispec = [(risstv1_c, U1_c), (risstv2_c, U2_c)]
    val tbt_1 = "(≤)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(<ow)"
    val tbt_2 = "(≤)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_2 = "(<ow)"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args = (((((rispec, sbtspec), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error "tbts must be distinct"
  in
    UT_Test_Suite.assert_exception 
      "tbts must be distinct" 
      (args, ctxt) 
      (ERROR err_msg)
  end;

fun test_exc_sbterms_subset_rispec (ctxt : Proof.context) = 
  let
    (* input *)
    val risstv1_c = "?'a"
    val U1_c = "UA::'ao set"
    val rispec = [(risstv1_c, U1_c)]
    val tbt_1 = "(≤)::?'a::ord⇒?'a::ord⇒bool"
    val sbt_1 = "(≤ow)"
    val tbt_2 = "(<)::?'b::ord⇒?'b::ord⇒bool"
    val sbt_2 = "(<ow)"
    val sbtspec = [(tbt_1, sbt_1), (tbt_2, sbt_2)]
    val args : ETTS_Context.amend_ctxt_data_input_type = 
      (((((rispec, sbtspec), NONE), []), NONE), [])
    val err_msg = mk_msg_tts_ctxt_error 
      "the collection of the (stv, ftv) pairs associated with the sbterms " ^
      "must form a subset of the collection of the (stv, ftv) pairs " ^
      "associated with the RI specification, provided that only the pairs " ^
      "(stv, ftv) associated with the sbterms such that ftv occurs in a " ^
      "premise of a theorem associated with an sbterm are taken into account"
  in
    UT_Test_Suite.assert_exception 
      "tbts " 
      (args, ctxt) 
      (ERROR err_msg)
  end;



(**** Test suite ****)

local

val test_amend_context_data = uncurry ETTS_Context.amend_context_data;

fun test_amend_context_string_of_input (args, ctxt) = 
  let 
    val c =
      "ctxt : unknown context\n" ^ 
      ETTS_Context.string_of_amend_context_data_args ctxt args
  in c end;

in

fun mk_test_suite_amend_context_data ctxt = 
  let
    fun string_of_tts_ctxt_data (ctxt_data, ctxt) = 
      ETTS_Context.string_of_tts_ctxt_data ctxt ctxt_data
    val test_suite_amend_context_data = UT_Test_Suite.init
      "amend_context_data"
      test_amend_context_data
      test_amend_context_string_of_input
      string_of_tts_ctxt_data
    val thy = Proof_Context.theory_of ctxt
  in
    test_suite_amend_context_data
    (*valid inputs*)
    |> test_eq_tts_context ctxt
    (*exceptions: general*)
    |> test_exc_tts_context_tts_context thy
    (*exceptions: rispec*)
    |> test_exc_rispec_empty thy
    |> test_exc_rispec_not_set thy
    |> test_exc_rispec_duplicate_risstvs thy
    |> test_exc_rispec_not_ds_dtv thy
    |> test_exc_rispec_not_dt_dv thy
    (*exceptions: sbtspec*)
    |> test_exc_distinct_sorts ctxt
    |> test_exc_sbts_no_tis ctxt
    |> test_exc_tbt_fixed ctxt
    |> test_exc_sbts_not_registered ctxt
    |> test_exc_tbts_not_distinct ctxt
    |> test_exc_sbterms_subset_rispec ctxt
  end;

fun execute_test_suite_amend_context_data ctxt = 
  UT_Test_Suite.execute (mk_test_suite_amend_context_data ctxt)

end;

end;

File ‹ETTS_TEST_TTS_ALGORITHM.ML›

(* Title: ETTS/Tests/ETTS_TEST_TTS_ALGORITHM.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

signature ETTS_TEST_TTS_ALGORITHM =
sig

type tts_algorithm_in_type
val execute_test_suite_tts_algorithm : 
  Proof.context ->
  (tts_algorithm_in_type,
  (thm * int list) * Proof.context)
  UT_Test_Suite.test_results_suite

end;

structure etts_test_tts_algorithm : ETTS_TEST_TTS_ALGORITHM =
struct



(**** Auxiliary ****)

fun mk_msg_tts_algorithm_error msg = "tts_algorithm: " ^ msg



(*** Data ***)

type tts_algorithm_in_type = 
  Proof.context *
  ETTS_Algorithm.etts_output_type *
  int list *
  (indexname * term) list *
  (term * term) list *
  (Facts.ref * Token.src list) option *
  (Facts.ref * Token.src list) list *
  (term list * (Proof.context -> tactic)) option * 
  Token.src list *
  thm;



(*** String I/O ***)

fun string_of_writer writer = writer 
  |> ML_Syntax.print_list Int.toString 
  |> curry op^ "writer: "



(*** Relation for the outputs ***)

fun rel_tts_algorithm_out
  (
    act_out : (thm * int list) * Proof.context, 
    exp_out : (thm * int list) * Proof.context
  ) =
  let
    val ((thm_act_out, writer_act_out), _) = act_out
    val ((thm_exp_out, writer_exp_out), _) = exp_out
    val t_act_out = Thm.full_prop_of thm_act_out 
    val t_exp_out = Thm.full_prop_of thm_exp_out
  in 
    t_act_out aconv t_exp_out 
    andalso writer_act_out = writer_exp_out
  end;




(**** Tests ****)



(*** Valid inputs ***)

fun test_eq_tts_algorithm (ctxt : Proof.context) = 
  let

    (*input*)
    val tts_ctxt_data = ETTS_Context.get_tts_ctxt_data ctxt
    val rispec = #rispec tts_ctxt_data
    val sbtspec = #sbtspec tts_ctxt_data
    val sbrr_opt = #sbrr_opt tts_ctxt_data
    val subst_thms = #subst_thms tts_ctxt_data
    val mpespc_opt = #mpespc_opt tts_ctxt_data
    val attrbs = #attrbs tts_ctxt_data
    val tts_output_type = ETTS_Algorithm.default
    val writer_in = [1, 1, 1, 1]
    val in_thm = @{thm tta_semigroup_hom.tta_left_ideal_closed}
    val tts_algorithm_in : tts_algorithm_in_type = 
      (
        ctxt,
        tts_output_type, 
        writer_in, 
        rispec,
        sbtspec, 
        sbrr_opt, 
        subst_thms, 
        mpespc_opt,
        attrbs,
        in_thm
      )

    (*output*)
    val writer_out = [1, 3, 1, 1]
    val exp_tts_algorithm_out = 
      ((@{thm tta_left_ideal_ow_closed}, writer_out), ctxt)

  in
    UT_Test_Suite.assert_brel
      "equality"
      rel_tts_algorithm_out
      exp_tts_algorithm_out
      tts_algorithm_in
  end;



(*** Exceptions ***)

fun test_exc_ftvs ctxt = 
  let
    val tts_ctxt_data = ETTS_Context.get_tts_ctxt_data ctxt
    val rispec = #rispec tts_ctxt_data
    val sbtspec = #sbtspec tts_ctxt_data
    val sbrr_opt = #sbrr_opt tts_ctxt_data
    val subst_thms = #subst_thms tts_ctxt_data
    val mpespc_opt = #mpespc_opt tts_ctxt_data
    val attrbs = #attrbs tts_ctxt_data
    val tts_output_type = ETTS_Algorithm.default
    val writer_in = [1, 1, 1, 1]
    val in_thm = @{thm exI'[where 'a='a]}
    val tts_algorithm_in : tts_algorithm_in_type = 
      (
        ctxt,
        tts_output_type, 
        writer_in, 
        rispec,
        sbtspec, 
        sbrr_opt, 
        subst_thms, 
        mpespc_opt,
        attrbs,
        in_thm
      )
    val err_msg = mk_msg_tts_algorithm_error
      "fixed type variables must not occur in the type-based theorems"
  in
    UT_Test_Suite.assert_exception 
      "fixed type variables" 
      tts_algorithm_in
      (ERROR err_msg)
  end;

fun test_exc_fvs ctxt = 
  let
    val tts_ctxt_data = ETTS_Context.get_tts_ctxt_data ctxt
    val rispec = #rispec tts_ctxt_data
    val sbtspec = #sbtspec tts_ctxt_data
    val sbrr_opt = #sbrr_opt tts_ctxt_data
    val subst_thms = #subst_thms tts_ctxt_data
    val mpespc_opt = #mpespc_opt tts_ctxt_data
    val attrbs = #attrbs tts_ctxt_data
    val tts_output_type = ETTS_Algorithm.default
    val writer_in = [1, 1, 1, 1]
    val aT = TVar (("'a", 0), sort‹type›)
    val xv = ("x", 0)
    val xt = Free ("x", aT) |> Thm.cterm_of ctxt
    val in_thm = Drule.instantiate_normalize ([], [((xv, aT), xt)]) @{thm exI'}
    val tts_algorithm_in : tts_algorithm_in_type = 
      (
        ctxt,
        tts_output_type,
        writer_in,
        rispec,
        sbtspec,
        sbrr_opt,
        subst_thms,
        mpespc_opt,
        attrbs,
        in_thm
      )
    val err_msg = mk_msg_tts_algorithm_error
      "fixed variables must not occur in the type-based theorems"
  in
    UT_Test_Suite.assert_exception 
      "fixed variables" 
      tts_algorithm_in
      (ERROR err_msg)
  end;

fun test_exc_not_risstv_subset ctxt = 
  let
    val tts_ctxt_data = ETTS_Context.get_tts_ctxt_data ctxt
    val rispec = #rispec tts_ctxt_data
    val sbtspec = #sbtspec tts_ctxt_data
    val sbrr_opt = #sbrr_opt tts_ctxt_data
    val subst_thms = #subst_thms tts_ctxt_data
    val mpespc_opt = #mpespc_opt tts_ctxt_data
    val attrbs = #attrbs tts_ctxt_data
    val tts_output_type = ETTS_Algorithm.default
    val writer_in = [1, 1, 1, 1]
    val in_thm = @{thm tta_semigroup.tta_assoc}
    val tts_algorithm_in : tts_algorithm_in_type = 
      (
        ctxt,
        tts_output_type,
        writer_in,
        rispec,
        sbtspec,
        sbrr_opt,
        subst_thms,
        mpespc_opt,
        attrbs,
        in_thm
      )
    val err_msg = mk_msg_tts_algorithm_error
      "risstv must be a subset of the schematic type " ^
      "variables that occur in the type-based theorems"
  in
    UT_Test_Suite.assert_exception
      "risstv is not a subset of the stvs of the type-based theorems" 
      tts_algorithm_in
      (ERROR err_msg)
  end;

fun test_not_tts_context thy = 
  let
    val ctxt = Proof_Context.init_global thy                    
    val tts_ctxt_data = ETTS_Context.get_tts_ctxt_data ctxt
    val rispec = #rispec tts_ctxt_data
    val sbtspec = #sbtspec tts_ctxt_data
    val sbrr_opt = #sbrr_opt tts_ctxt_data
    val subst_thms = #subst_thms tts_ctxt_data
    val mpespc_opt = #mpespc_opt tts_ctxt_data
    val attrbs = #attrbs tts_ctxt_data
    val tts_output_type = ETTS_Algorithm.default
    val writer_in = [1, 1, 1, 1]
    val in_thm = @{thm tta_semigroup_hom.tta_left_ideal_closed}
    val tts_algorithm_in : tts_algorithm_in_type = 
      (
        ctxt,
        tts_output_type, 
        writer_in, 
        rispec,
        sbtspec, 
        sbrr_opt, 
        subst_thms, 
        mpespc_opt,
        attrbs,
        in_thm
      )
    val err_msg = mk_msg_tts_algorithm_error
      "ERA can only be invoked from an appropriately parameterized tts context"
  in
    UT_Test_Suite.assert_exception 
      "not tts context" 
      tts_algorithm_in
      (ERROR err_msg)
  end;




(**** Test suite ****)

local

fun string_of_rispec ctxt = 
  ML_Syntax.print_pair (Term.string_of_vname) (Syntax.string_of_term ctxt)
  |> ML_Syntax.print_list;

fun string_of_sbtspec ctxt =
  let val string_of_term = Syntax.string_of_term ctxt
  in 
    ML_Syntax.print_pair string_of_term string_of_term 
    |> ML_Syntax.print_list
  end;

fun tts_algorithm_string_of_input (tts_algorithm_in : tts_algorithm_in_type) = 
  let
    val 
      (
        ctxt,
        tts_output_type, 
        writer, 
        rispec,
        sbtspec, 
        sbrr_opt, 
        subst_thms, 
        mpespc_opt,
        attrbs,
        thm
      ) = tts_algorithm_in
    val ctxt_c = "ctxt: unknown context" 
    val tts_output_type_c =
      ETTS_Algorithm.string_of_etts_output_type tts_output_type
    val writer_c = string_of_writer writer 
    val rispec_c = rispec |> string_of_rispec ctxt |> curry op^ "rispec: "
    val sbtspec_c = sbtspec |> string_of_sbtspec ctxt |> curry op^ "sbtspec: "
    val sbrr_opt_c = sbrr_opt 
      |> ETTS_Context.string_of_sbrr_opt 
      |> curry op^ "sbrr_opt: "
    val subst_thms_c = subst_thms
      |> ETTS_Context.string_of_subst_thms
      |> curry op^ "subst_thms: "
    val mpespc_opt_c = mpespc_opt
      |> ETTS_Context.string_of_mpespc_opt ctxt
      |> curry op^ "mpespc_opt: "
    val attrbs_c = attrbs |> string_of_token_src_list |> curry op^ "attrbs: "
    val thm_c = thm |> Thm.string_of_thm ctxt |> curry op^ "in_thm: "
    val out_c = 
      [
        ctxt_c,
        tts_output_type_c,
        writer_c,
        rispec_c,
        sbtspec_c,
        sbrr_opt_c,
        subst_thms_c,
        mpespc_opt_c,
        attrbs_c,
        thm_c
      ]
      |> String.concatWith "\n"
  in out_c end;

fun tts_algorithm_string_of_output 
  (((thm, writer), ctxt) : (thm * int list) * Proof.context) = 
  let
    val ctxt_c = "ctxt: unknown context" 
    val thm_c = Thm.string_of_thm ctxt thm
    val writer_c = ML_Syntax.print_list Int.toString writer
    val out_c = [ctxt_c, thm_c, writer_c] |> String.concatWith "\n"
  in out_c end;

fun tts_algorithm (tts_algorithm_in : tts_algorithm_in_type) =
  let
    val 
      (
        ctxt,
        tts_output_type, 
        writer, 
        rispec,
        sbtspec, 
        sbrr_opt, 
        subst_thms, 
        mpespc_opt,
        attrbs,
        thm
      ) = tts_algorithm_in
    val tts_algorithm_out = 
      ETTS_Algorithm.etts_algorithm
        ctxt 
        tts_output_type 
        writer
        rispec 
        sbtspec 
        sbrr_opt 
        subst_thms 
        mpespc_opt 
        attrbs 
        thm
  in tts_algorithm_out end;

in

fun mk_test_suite_tts_algorithm ctxt =
  let
    val test_suite_tts_algorithm = UT_Test_Suite.init
      "tts_algorithm"
      tts_algorithm
      tts_algorithm_string_of_input
      tts_algorithm_string_of_output
  in
    test_suite_tts_algorithm
    |> test_eq_tts_algorithm ctxt
    |> test_exc_ftvs ctxt
    |> test_exc_fvs ctxt
    |> test_exc_not_risstv_subset ctxt
    |> test_not_tts_context (Proof_Context.theory_of ctxt)
  end;

end;

fun execute_test_suite_tts_algorithm ctxt = 
  UT_Test_Suite.execute (mk_test_suite_tts_algorithm ctxt);

end;

File ‹ETTS_TEST_TTS_REGISTER_SBTS.ML›

(* Title: ETTS/Tests/ETTS_TEST_TTS_REGISTER_SBTS.ML
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

signature ETTS_TEST_TTS_REGISTER_SBTS =
sig

type tts_register_sbts_in_type
val execute_test_suite_tts_register_sbts : 
  Proof.context ->
  (tts_register_sbts_in_type, Proof.state) 
    UT_Test_Suite.test_results_suite

end;

structure etts_test_tts_register_sbts : ETTS_TEST_TTS_REGISTER_SBTS =
struct




(**** Auxiliary ****)

fun mk_msg_tts_register_sbts_error msg = "tts_register_sbts: " ^ msg



(*** Data ***)

type tts_register_sbts_in_type = 
  (string * string list) * Proof.context



(*** Exceptions ***)

fun test_exc_fvs ctxt = 
  let
    
    val sbt = "g::'q"
    val UA_c = "UA::'a set"
    val UB_c = "UB::'b set"
    val rissest = [UA_c, UB_c]

    val tts_register_sbts_in : tts_register_sbts_in_type = 
      ((sbt, rissest), ctxt)

    val err_msg = mk_msg_tts_register_sbts_error
      "all fixed variables that occur in the sbterm " ^
      "must be fixed in the context"

  in
    UT_Test_Suite.assert_exception
      "variables not fixed in the context"
      tts_register_sbts_in
      (ERROR err_msg)
  end;

fun test_exc_repeated_risset ctxt = 
  let
    
    val sbt = "f"
    val UA_c = "UA::'a set"
    val UB_c = "UA::'a set"
    val rissest = [UA_c, UB_c]

    val tts_register_sbts_in : tts_register_sbts_in_type = 
      ((sbt, rissest), ctxt)

    val err_msg = mk_msg_tts_register_sbts_error
      "the type variables associated with the risset must be distinct"

  in
    UT_Test_Suite.assert_exception
      "repeated risset"
      tts_register_sbts_in
      (ERROR err_msg)
  end;




(**** Test suite ****)

local

fun tts_register_sbts_string_of_input 
  (tts_register_sbts_in : tts_register_sbts_in_type) = 
  let
    val ((sbt, risset), _) = tts_register_sbts_in
    val ctxt_c = "ctxt: unknown context" 
    val sbt_c = "sbt: " ^ sbt
    val risset_c = "risset: " ^ ML_Syntax.print_list I risset
    val out_c = [ctxt_c, sbt_c, risset_c]
      |> String.concatWith "\n"
  in out_c end;

fun tts_register_sbts_string_of_output (_ : Proof.state) = 
  let val st_c = "st: unknown state" 
  in st_c end;

fun tts_register_sbts ((args, ctxt) : tts_register_sbts_in_type) = 
  ETTS_Substitution.process_tts_register_sbts args ctxt;

in

fun mk_test_suite_tts_register_sbts ctxt =
  let
    val test_suite_tts_register_sbts = UT_Test_Suite.init
      "tts_register_sbts"
      tts_register_sbts
      tts_register_sbts_string_of_input
      tts_register_sbts_string_of_output
  in
    test_suite_tts_register_sbts
    |> test_exc_fvs ctxt
    |> test_exc_repeated_risset ctxt
  end;

end;

fun execute_test_suite_tts_register_sbts ctxt = 
  UT_Test_Suite.execute (mk_test_suite_tts_register_sbts ctxt);

end;

Theory ETTS_Introduction

(* Title: ETTS/Manual/ETTS_Introduction.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

chapter‹ETTS: Reference Manual›

section‹Introduction›
theory ETTS_Introduction
  imports 
    Manual_Prerequisites  
    "HOL-Library.Conditional_Parametricity"
begin



subsection‹Background›


text‹
The \textit{standard library} that is associated with the object logic 
Isabelle/HOL and provided as a part of the standard distribution of Isabelle 
\cite{noauthor_isabellehol_2020} 
contains a significant number of formalized results from a variety of 
fields of mathematics (e.g., order theory, algebra, topology).
Nevertheless, using the vocabulary that was promoted in the original article on
Types-To-Sets \cite{blanchette_types_2016}, the formalization is 
performed using a type-based approach. Thus, for example, the carrier sets 
associated with the algebraic structures and the underlying sets of the 
topological spaces consist of all terms of an arbitrary type. This restriction 
can create an inconvenience when working with mathematical objects 
induced on a subset of the carrier set/underlying set associated with 
the original object (e.g., see \cite{immler_smooth_2019}).

To address this limitation, several additional libraries were developed 
upon the foundations provided by the the standard library 
(e.g., \textit{HOL-Algebra}
\cite{ballarin_isabellehol_2020} and \textit{HOL-Analysis} 
\cite{noauthor_isabellehol_2020-1}). 
In terms of the vocabulary associated with 
Types-To-Sets, these libraries provide the set-based counterparts of many
type-based theorems in the standard library, along with a plethora of 
additional results. Nonetheless, the proofs of the majority of the theorems 
that are available in the standard library are restated explicitly in the 
libraries that contain the set-based results. This unnecessary duplication of 
efforts is one of the primary problems that the framework Types-To-Sets is 
meant to address. 

The framework Types-To-Sets offers a unified approach to structuring 
mathematical knowledge formalized in Isabelle/HOL: every type-based theorem 
can be converted to a set-based theorem in a semi-automated manner and the 
relationship between such type-based and set-based theorems can be 
articulated clearly and explicitly \cite{blanchette_types_2016}. 
In this article, we describe a particular implementation of the framework 
Types-To-Sets in Isabelle/HOL that takes the form of a further extension of 
the language Isabelle/Isar with several new commands and attributes 
(e.g., see \cite{wenzel_isabelle/isar_2019-1}).
›



subsection‹Previous work›


subsubsection‹Prerequisites and conventions›


text‹
A reader of this document is assumed to be familiar with 
the proof assistant Isabelle, the proof language Isabelle/Isar,
the meta-logic Isabelle/Pure and
the object logic Isabelle/HOL, as described in, 
\cite{paulson_natural_1986, wenzel_isabelle/isar_2019-1},
\cite{bertot_isar_1999, wenzel_isabelleisar_2007, wenzel_isabelle/isar_2019-1},
\cite{paulson_foundation_1989, wenzel_isabelle/isar_2019-1} and
\cite{yang_comprehending_2017}, respectively. Familiarity with the
content of the original articles about Types-To-Sets
\cite{blanchette_types_2016,kuncar_types_2019} and
the first large-scale application of Types-To-Sets
(as described in \cite{immler_smooth_2019}) 
is not essential but can be useful.

The notational conventions that are used in this document are
approximately equivalent to the conventions that were suggested in
\cite{blanchette_types_2016}, \cite{yang_comprehending_2017} and
\cite{kuncar_types_2019}; nonetheless, we try to provide 
explanations whenever deemed essential in an attempt to make this body of work
self-contained. As a side note, the types of the 
typed variables and constant-instances may be omitted
at will, if it is deemed that they can be inferred from the
context of the discussion.
›


subsubsection‹A note on global schematic polymorphism›


text‹
In Isabelle/Pure, a distinction is made between schematic and fixed
variables (for example, see \cite{paulson_foundation_1989} or
\cite{wenzel_isabelle/isar_2001}).
Implicitly, Isabelle/HOL also inherits this distinction.
More specifically, free variables that occur in the theorems at the top-level
of the theory context are generalized implicitly, which may be expressed by
replacing fixed variables by schematic variables
(e.g., see \cite{wenzel_isabelle/isar_2001}).
However, from the perspective of logic,
the distinction between the fixed and the schematic variables
is superficial: they are merely distinct syntactic expressions
of the same formal concept of variables 
(e.g., see \cite{wenzel_isabelle/isar_2001}).

In this document, following a standard convention, 
the names of the schematic variables will be prefixed with the question 
mark ``$?$''. Thus, $?a$, $?b$, $\ldots$ will be used for the denotation 
of schematic term variables and $?\alpha$, $?\beta$, $\ldots$ will be used 
for the denotation of the schematic type variables. 
Like in the previous work on Types-To-Sets, by abuse of notation, 
explicit quantification over the type variables at the top level is allowed: 
$\forall \alpha. \phi\left[\alpha\right]$. However, 
the schematic variables will nearly always be treated 
explicitly, like they are treated in the programmatic implementation 
of the algorithms. It should also be noted that, apart from the 
conventional use of the square brackets for the denotation of substitution,
they may be used informally to indicate that certain 
types and/or terms are a part of a term, e.g., 
$t\left[?\alpha\right]$, $t\left[\sigma, c_{\tau}\right]$.
›


subsubsection‹Relativization Algorithm\label{sec:ra}›


text‹
Let ${}_{\alpha}(\beta \approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}$ denote
\[
\begin{aligned}
& (\forall x_{\beta}. \mathsf{Rep}\ x \in A)\ \wedge\\
& (\forall x_{\beta}. \mathsf{Abs}\ (\mathsf{Rep}\ x) = x)\ \wedge\\
& (\forall y_{\alpha}. y \in A \longrightarrow \mathsf{Rep}\ (\mathsf{Abs}\ y) = y)
\end{aligned},
\]
let $\rightsquigarrow$ denote the constant/type dependency relation 
(see subsection 2.3 in \cite{blanchette_types_2016}), 
let $\rightsquigarrow^{\downarrow}$ 
be a substitutive closure of the constant/type dependency relation, 
let $R^{+}$ denote the transitive closure of 
the binary relation $R$, let $\Delta_c$ denote the set of all types for which 
$c$ is overloaded and let $\sigma\not\leq S $ mean that $\sigma$ is not an 
instance of any type in $S$ (see \cite{blanchette_types_2016} and 
\cite{yang_comprehending_2017}).

The framework Types-To-Sets extends Isabelle/HOL with two axioms: 
Local Typedef Rule (LT) and the Unoverloading Rule (UO). 
The consistency of Isabelle/HOL augmented with the LT and
the UO is proved in Theorem 11 in \cite{yang_comprehending_2017}.

The LT is given by
\[
\begin{aligned}
\scalebox{1.0}{
\infer[\beta \not\in A, \phi, \Gamma]{\Gamma \vdash \phi}{%
\Gamma\vdash A \neq\emptyset
& \Gamma
  \vdash
  \left( 
    \exists \mathsf{Abs}\ \mathsf{Rep}. {}_{\sigma}(\beta\approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}\longrightarrow\phi 
  \right)
} 
}
\end{aligned}
\]

Thus, if $\beta$ is fresh for the non-empty set $A_{\sigma\ \mathsf{set}}$, 
the formula $\phi$ and the context $\Gamma$, then $\phi$ can be proved in 
$\Gamma$ by assuming the existence of a type $\beta$ isomorphic to $A$.

The UO is given by
\[
\infer[\text{$\forall u$ in $\phi$}. \neg(u\rightsquigarrow^{\downarrow+}c_{\sigma});\ \sigma\not\leq\Delta_c]{\forall x_{\sigma}. \phi\left[x_{\sigma}/c_{\sigma}\right]}{\phi}
\]
Thus, a constant-instance $c_{\sigma}$ may be replaced by a universally 
quantified variable $x_{\sigma}$ in $\phi$, if all types and 
constant-instances in $\phi$ do not semantically depend on $c_{\sigma}$ 
through a chain of constant and type definitions and there is no 
matching definition for $c_{\sigma}$.

The statement of the \textit{original relativization algorithm} (ORA) can be 
found in subsection 5.4 in \cite{blanchette_types_2016}. Here, we present
a variant of the algorithm that includes some of the amendments that were 
introduced in \cite{immler_smooth_2019}, which will be referred to as the 
\textit{relativization algorithm} (RA). 
The differences between the ORA and 
the RA are implementation-specific and have no effect on the output 
of the algorithm, if applied to a conventional input.
Let $\bar{a}$ denote $a_1,\ldots,a_n$ for some positive integer $n$; 
let $\Upsilon$ be a type class 
\cite{nipkow_type_1991,wenzel_type_1997,altenkirch_constructive_2007} 
that depends on the overloaded constants $\bar{*}$ and 
let $A\downarrow\bar{f}$ be used 
to state that $A$ is closed under the operations $\bar{f}$; 
then the RA is given by 
\[
\scalebox{0.75}{
\infer[(7)]
{
\vdash ?A_{?\alpha\ \mathsf{set}} \neq\emptyset\longrightarrow
?A\downarrow?\bar{f}\left[?\alpha\right]\longrightarrow
\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ ?A\ ?\bar{f}\longrightarrow
\phi^{\mathsf{on}}_{\mathsf{with}}\left[?\alpha,?A,?\bar{f}\right]
}
{
\infer[(6)]
{
A\neq\emptyset
\vdash A\downarrow?\bar{f}\left[\alpha\right]\longrightarrow
\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ A\ ?\bar{f}\longrightarrow
\phi^{\mathsf{on}}_{\mathsf{with}}\left[\alpha,A,?\bar{f}\right]
}
{
\infer[(5)]
{
A\neq\emptyset,{}_{\alpha}(\beta\approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}
\vdash A\downarrow?\bar{f}\left[\alpha\right]\longrightarrow
\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ A\ ?\bar{f}\longrightarrow
\phi^{\mathsf{on}}_{\mathsf{with}}\left[\alpha,A,?\bar{f}\right]
}
{
\infer[(4)]
{
A\neq\emptyset,{}_{\alpha}(\beta\approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}
\vdash\Upsilon_{\mathsf{with}}\ ?\bar{f}\left[\beta\right]\longrightarrow
\phi_{\mathsf{with}}\left[\beta,?\bar{f}\right]
}
{
\infer[(3)]
{
A\neq\emptyset,{}_{\alpha}(\beta\approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}
\vdash\Upsilon_{\mathsf{with}}\ ?\bar{f}\left[?\alpha\right]\longrightarrow
\phi_{\mathsf{with}}\left[?\alpha,?\bar{f}\right]
}
{
\infer[(2)]
{
\vdash\Upsilon_{\mathsf{with}}\ ?\bar{f}\left[?\alpha\right]\longrightarrow
\phi_{\mathsf{with}}\left[?\alpha,?\bar{f}\right]
}
{
\infer[(1)]
{\vdash\phi_{\mathsf{with}}\left[?\alpha_{\Upsilon},\bar{*}\right]}
{\vdash\phi\left[?\alpha_{\Upsilon}\right]}
}
}
}
}
}
}
}
\]
The input to the RA
is assumed to be a theorem $\vdash\phi\left[?\alpha_{\Upsilon}\right]$ 
such that all of its unbound term and type variables are schematic.
Step 1 will be referred to as the first step of the dictionary 
construction (it is similar to the first step of the 
dictionary construction, as described in subsection 5.2 in
\cite{blanchette_types_2016});
step 2 will be described as unoverloading of the type $?\alpha_{\Upsilon}$ 
and includes class internalization 
(see subsection 5.1 in \cite{blanchette_types_2016} and 
\cite{altenkirch_constructive_2007}) 
and the application of the UO (step 2 corresponds to the application of the
attribute @{attribute unoverload_type} that will be 
described in the next subsection); step 3 provides the assumptions
\mbox{$A_{\alpha\ \mathsf{set}}\neq\emptyset$} and 
\mbox{${}_{\alpha}(\beta\approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}$} 
(the prerequisites for the application of the LT); step 4 is reserved
for the concrete type instantiation; 
step 5 refers to the application of transfer 
(see section 6 in \cite{blanchette_types_2016}); step 6 refers to the 
application of the LT; step 7 refers to the export of the theorem
from the local context (e.g., see \cite{wenzel_isabelle/isar_2019}).
›


subsubsection‹Implementation of Types-To-Sets\label{subsec:ITTS}›


text‹
In \cite{blanchette_types_2016}, the authors provided the first
programmatic implementation of the framework Types-To-Sets for Isabelle/HOL 
in the form of several Isabelle/ML modules 
(see \cite{milner_definition_1997} and \cite{wenzel_isabelle/isar_2019}). 
These modules extended the 
implementation of the object logic Isabelle/HOL with the
LT and UO. Moreover, they introduced several attributes that provided a 
convenience layer for the application of the ORA:
@{attribute internalize_sort}, @{attribute unoverload}
and @{attribute cancel_type_definition}. 
These attributes could be used to perform steps 1, 3 and 7 (respectively) of 
the ORA. Other steps could be performed using the technology that already 
existed, but required a significant effort and knowledge on behalf of the users 
(e.g., see \cite{immler_smooth_2019}).

The examples of the application of the ORA to theorems in 
Isabelle/HOL that were developed in \cite{blanchette_types_2016}
already contained an implicit suggestion that the constants and theorems 
needed for the first step of the dictionary construction in step 2 of 
the ORA and the transfer rules needed for step 6 of the ORA can and should 
be obtained prior to the application of the algorithm. Thus, using the notation
from subsection \ref{sec:ra},
for each constant-instance $c_{\sigma}$ 
that occurs in the type-based theorem 
$\vdash\phi\left[?\alpha_{\Upsilon}\right]$
prior to the application of the ORA with respect to 
${}_{\alpha}(\beta \approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}$, 
the users were expected to provide
an unoverloaded constant $c_{\mathsf{with}}$ such that 
$c_{\sigma} = c_{\mathsf{with}}\ \bar{*}$, and a constant $c^{\mathsf{on}}_{\mathsf{with}}$ 
such that $R\left[T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}}\right]
\ (c^{\mathsf{on}}_{\mathsf{with}}\ A_{\alpha\ \mathsf{set}})\ c_{\mathsf{with}}$ 
($\mathbb{B}$ denotes the built-in Isabelle/HOL type $bool$
\cite{kuncar_types_2015})
is a conditional transfer rule (e.g., see \cite{gonthier_lifting_2013}), 
with $T$ being a binary 
relation that is at least right-total and bi-unique 
(see \cite{kuncar_types_2015}), assuming the default order on predicates
in Isabelle/HOL. 
In \cite{immler_smooth_2019}, the implementation of the framework Types-To-Sets
was amended by providing the attribute @{attribute unoverload_type}, 
which subsumed the functionality of the attributes 
@{attribute internalize_sort} and 
@{attribute unoverload}. The RA presented above already includes this
amendment.

Potentially, the unoverloaded constants $c_{\mathsf{with}}$ and the 
associated theorems $c_{\sigma} = c_{\mathsf{with}}\ \bar{*}$ 
can be obtained via the application of the algorithm for unoverloading 
of definitions that was proposed in 
\cite{kaufmann_mechanized_2010}.
However, to the best knowledge of the author, a working implementation of this 
\textit{classical overloading elimination algorithm} 
is not publicly available for the most recent version of Isabelle.
In \cite{immler_automation_2019}, an alternative
algorithm that serves a similar purpose is provided and  
made available via the interface of the Isabelle/Isar command
@{command unoverload_definition}. 
Effectively, the command applies the algorithm used
in the attribute @{attribute unoverload_type}
to a definition of the constant $c$ and uses the right-hand-side 
of the resulting theorem to form a definition for $c_{\mathsf{with}}$.
Thus, technically, unlike the classical overloading elimination
algorithm, this algorithm requires the axiom UO to be available and it is 
not capable of unoverloading the constants that were not overloaded 
using the Isabelle's type class infrastructure. Furthermore,
the command is applicable only to the definitions provided by the user, 
which could be seen as an obstacle in the automation of unoverloading of 
the constants that are defined using the definitional packages other 
than @{command definition} (the classical overloading elimination 
algorithm relies on the definitional axioms instead of arbitrary 
theorems provided by the user \cite{kaufmann_mechanized_2010}). 
Of course, none of these limitations hinder the usefulness of the command, 
if it is applicable. 

The transfer rules for the constants that are conditionally parametric 
can be synthesized automatically using the existing command 
@{command parametric_constant}
\cite{gilcher_conditional_2017} 
that is available from the standard distribution of Isabelle;
the framework \textit{autoref} that was developed in 
\cite{lammich_automatic_2013} allows for the synthesis of transfer rules 
$R\ t\ t'$, including both the transfer relation $R$ and the term $t$,
based on $t'$, under favorable conditions;
lastly, in \cite{lammich_automatic_2013} and \cite{immler_smooth_2019}, 
the authors suggest an outline of another feasible algorithm for the 
synthesis of the transfer rules based on the functionality of the framework 
\textit{transfer} \cite{gonthier_lifting_2013} of Isabelle/HOL, 
but do not provide an implementation (the main algorithm presented
in \cite{lammich_automatic_2013} is independent of the standard transfer 
framework of Isabelle/HOL).

Lastly, the assumption ${}_{\alpha}(\beta \approx A)_{\mathsf{Rep}}^{\mathsf{Abs}}$ can be 
stated using the 
constant \isa{type{\isacharunderscore}definition}
from the standard library of Isabelle/HOL as 
\isa{type{\isacharunderscore}definition\ $\mathsf{Rep}$\ $\mathsf{Abs}$\ $A$}; 
the instantiation of types required in step 4 of the RA can 
be performed using the standard attributes of Isabelle; 
step 6 can be performed using the attribute 
@{attribute cancel_type_definition} developed in 
\cite{blanchette_types_2016}; step 7 is expected to be performed manually
by the user.
›



subsection‹Purpose and scope›


text‹
The extension of the framework Types-To-Sets that is described in this manual
adds a further layer of automation to the existing implementation
of the framework Types-To-Sets. The primary functionality of the extension 
is available via the following Isar commands: 
@{command tts_context}, @{command tts_lemmas} and @{command tts_lemma} (and the
synonymous commands @{command tts_corollary}, @{command tts_proposition} and
@{command tts_theorem}\footnote{In what follows, any reference to the 
command @{command tts_lemma} should be viewed as a reference to the 
entire family of the commands with the identical functionality.}).
The commands @{command tts_lemmas} and @{command tts_lemma}, when invoked inside
an appropriately defined @{command tts_context} provide the 
functionality that is approximately equivalent to the application of all 
steps of the RA and several additional steps of 
pre-processing of the input and post-processing of the result
(collectively referred to as the \textit{extended relativization algorithm} 
or ERA).

The extension was designed under a policy of non-intervention with the  
existing implementation of the framework Types-To-Sets. Therefore, it does
not reduce the scope of the applicability of the framework. 
However, the functionality that is provided by the commands associated with the 
extension is a proper subset of the functionality provided by the existing 
implementation. Nevertheless, the author of the extension believes that there 
exist very few practical applications of the relativization algorithm that 
can be solved using the original interface but cannot be solved using 
the commands that are introduced within the scope of the 
extension.
›

text‹\newpage›

end

Theory ETTS_Theory

(* Title: ETTS/Manual/ETTS_Theory.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

section‹ETTS and ERA›
theory ETTS_Theory
  imports ETTS_Introduction
begin



subsection‹Background›

text‹
In this section, we describe our implementation of the prototype software 
framework ETTS that offers the integration of Types-To-Sets with the 
Isabelle/Isar infrastructure and full automation of the application of 
the ERA under favorable conditions. 
The design of the framework rests largely on our 
interpretation of several ideas expressed by the authors 
of \cite{immler_smooth_2019}. 

It has already been mentioned that the primary functionality of the ETTS 
is available via the Isabelle/Isar commands 
@{command tts_context}, @{command tts_lemmas} and @{command tts_lemma}.
There also exist secondary commands aimed at resolving certain specific 
problems that one may encounter during relativization:
@{command tts_register_sbts} and @{command tts_find_sbts}.
More specifically, these commands provide means for using transfer rules 
stated in a local context during the step of the ERA that is similar 
to step 5 of the RA. The functionality of these commands is
explained in more detail in subsection \ref{sec:sbts} below.

It is important to note that the description of the ETTS presented
in this subsection is only a simplified model 
of its programmatic implementation in Isabelle/ML. 
›



subsection‹Preliminaries›


text‹
The ERA is an extension of the RA that 
provides means for the automation of a design pattern similar 
to the one that was proposed in \cite{immler_smooth_2019}, 
as well as several additional steps for pre-processing of the input 
and post-processing of the result of the relativization.
In a certain restricted sense the ERA can be seen as 
a localized form of the RA, as it provides additional infrastructure 
aimed specifically at making the relativization of theorems stated in the 
context of Isabelle's locales 
\cite{kammuller_locales_1999, berardi_locales_2004, ballarin_locales_2014} 
more convenient.

In what follows, assume the existence of an underlying 
well-formed theory $D$ (and an associated HOL signature $\Sigma$) 
that contains all definitional axioms that appear 
in the standard library of Isabelle/HOL. 
If \mbox{$\Gamma \vdash {}_{\alpha}(\beta \approx U)_{\mathsf{Rep}}^{\mathsf{Abs}}$}
and
$\beta, U_{\alpha\ \mathsf{set}}, \mathsf{Rep}_{\beta\rightarrow\alpha}, \mathsf{Abs}_{\alpha\rightarrow\beta} \in \Gamma$,
then the 4-tuple 
$(U_{\alpha\ \mathsf{set}}, \beta, \mathsf{Rep}_{\beta\rightarrow\alpha}, \mathsf{Abs}_{\alpha\rightarrow\beta})$,
will be referred to as a \textit{relativization isomorphism} (RI)
\textit{with respect to} $\Gamma$ (or RI, if $\Gamma$ can be inferred). 
Given the RI 
$(U_{\alpha\ \mathsf{set}},\beta,\mathsf{Rep}_{\beta\rightarrow\alpha},\mathsf{Abs}_{\alpha\rightarrow\beta})$, 
the term $U_{\alpha\ \mathsf{set}}$ will be referred to as the
\textit{set associated with the RI}, $\beta$ will be referred to as the 
\textit{type variable associated with the RI}, 
$\mathsf{Rep}_{\beta\rightarrow\alpha}$ will be referred to as the 
\textit{representation associated with the RI} 
and $\mathsf{Abs}_{\alpha\rightarrow\beta}$ will be referred
to as the \textit{abstraction associated with the RI}. 
Moreover, any typed term variable $T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}}$ 
such that $\Gamma \vdash T = (\lambda x\ y.\ \mathsf{Rep}\ y = x)$ will be referred to as the 
\textit{transfer relation associated with the RI}. 
$\Gamma \vdash Domainp\ T = (\lambda x.\ x \in U)$ that holds for 
this transfer relation will be referred to as the 
\textit{transfer domain rule associated with the RI}, 
$\Gamma \vdash bi\_ unique\ T$ and 
$\Gamma \vdash right\_ total\ T$ will be referred to as the 
\textit{side conditions associated with the RI}. For brevity, 
the abbreviation 
$\mathsf{dbr}[T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}},U_{\alpha\ \mathsf{set}}]$ 
will be used to mean that 
$Domainp\ T = (\lambda x.\ x \in U)$, $bi\_ unique\ T$
and $right\_ total\ T$ for any $\alpha$, $\beta$, 
$T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}}$ and $U_{\alpha\ \mathsf{set}}$.
›



subsection‹Set-based terms and their registration\label{sec:sbts}›


text‹
Perhaps, one of the most challenging aspects of the automation of the 
relativization process is related to the application of transfer during 
step 5 of the RA: a suitable transfer rule for a given constant-instance 
may exist only under non-conventional side conditions:
an important example that showcases this issue is the built-in constant 
$\varepsilon$ (see \cite{kuncar_types_2019} and \cite{immler_smooth_2019}
for further information). 
Unfortunately, the ETTS does not offer a fundamental solution to this problem: 
the responsibility for providing suitable transfer rules for the application 
of the ERA remains at the discretion of the user. 
Nonetheless, the ETTS does provide
additional infrastructure that may improve the user experience when
dealing with the transfer rules that can only be conveniently stated in 
an explicitly relativized local context (usually a relativized
locale): a common problem that was already explored in 
\cite{immler_smooth_2019}.

The authors of \cite{immler_smooth_2019} choose to perform the relativization
of theorems that stem from their specifications in a locale context 
from within another dedicated relativized locale context.
The relativized operations that are represented either by the locale parameters
of the relativized locale or remain overloaded constants associated with 
a given class constraint are lifted to the type variables associated with the 
RIs that are used for the application of a variant of the relativization
algorithm. This variant includes a step during which the 
variables introduced during unoverloading are substituted (albeit implicitly) 
for the terms that represent the lifted locale parameters and constants.
The additional infrastructure and the additional step 
are needed, primarily, for the relativization of the constants 
whose transfer rules can only be stated conveniently in the context
of the relativized locale. 

A similar approach is used in the ETTS. However, instead of explicitly 
declaring the lifted constants in advance of the application of the RA, 
the user is expected to perform the registration of the so-called 
\textit{set-based term} (sbterm) for each term of interest that 
is a relativization of a given concept. 

The inputs to the algorithm that is associated with the registration of the 
sbterms are a context $\Gamma$, a term $t : \bar{\alpha}\ K$ 
($K$, applied using a postfix notation, contains all information about 
the type constructors of the type $\bar{\alpha}\ K$) and a 
sequence of $n$ distinct typed variables $\bar{U}$ with distinct types of the
form ${\alpha\ \mathsf{set}}$, such that $\bar{\alpha}$ is also of length $n$,
all free variables and free type variables that occur in 
$t : \bar{\alpha}\ K$ also appear free in $\Gamma$
and $\bar{U}_i : \bar{\alpha}_i\ \mathsf{set}$ for all $i$, 
$1 \leq i \leq n$.

Firstly, a term
$
\exists b.
\ R\left[\bar{A}\right]_{\bar{\alpha}\ K \rightarrow \bar{\beta}\ K\rightarrow \mathbb{B}}\ t\ b
$
is formed, such 
that $R\left[\bar{A}\right]$ is a parametricity relation associated with 
some type $\bar{\gamma}\ K$ for $\bar{\gamma}$ of length $n$, such that the sets 
of the elements of $\bar{\alpha}$, $\bar{\beta}$ and $\bar{\gamma}$ are pairwise 
disjoint, $\bar{A}$ and $\bar{\beta}$ are both of length $n$,
the elements of $\bar{A}$, $\bar{\beta}$ and $\bar{\gamma}$ 
are fresh for $\Gamma$ and 
$\bar{A}_i : \bar{\alpha}_i\rightarrow \bar{\beta}_i\rightarrow\mathbb{B}$ 
for all $i$ such that $1 \leq i \leq n$. Secondly, the context $\Gamma'$ is built  
incrementally starting from $\Gamma$ by adding the formulae 
$\mathsf{dbr}[\bar{A}_i, \bar{U}_i]$
for each $i$ such that $1 \leq i \leq n$.
The term presented above serves as a goal that is meant to be
discharged by the user in $\Gamma'$, resulting in the deduction
\[
\Gamma \vdash 
\mathsf{dbr}[?\bar{A}_i, \bar{U}_i] \longrightarrow
\exists b.
\ R\left[?\bar{A}\right]_{\bar{\alpha}\ K \rightarrow ?\bar{\beta}\ K\rightarrow \mathbb{B}}\ t\ b
\]
(the index $i$ is distributed over $n$)
after the export to the context $\Gamma$.
Once the proof is completed, the result is registered in the so-called
\textit{sbt-database} allowing a lookup of such results by the 
sbterm $t$ (the terms and results are allowed to morph
when the lookup is performed from within a context different 
from $\Gamma$ \cite{kauers_context_2007}).
›



subsection‹Parameterization of the ERA\label{sec:par-ERA}›


text‹
Assuming the existence of some context $\Gamma$, the ERA is parameterized by
the \textit{RI specification}, \textit{the sbterm specification},
the \textit{rewrite rules for the set-based theorem},
the \textit{known premises for the set-based theorem},
the \textit{specification of the elimination of premises 
in the set-based theorem} and
the \textit{attributes for the set-based theorem}.
A sequence of the entities in the list above will be
referred to as the \textit{ERA-parameterization for} $\Gamma$.

The \textit{RI Specification} is a finite non-empty sequence
of pairs \mbox{$\left(?\gamma, U_{\alpha\ \mathsf{set}} \right)$} of
schematic type variables $\gamma$ and the typed term variables 
$U_{\alpha\ \mathsf{set}}$, such that $U_{\alpha\ \mathsf{set}} \in \Gamma$.
The individual elements of the RI specification will 
be referred to as the \textit{RI specification elements}.
Given an RI specification element, any type variable that occurs 
on the left hand side (LHS) of the RI specification element will be referred to as the 
\textit{type variable associated with the RI specification element},
any typed term variable that occurs on the right hand side (RHS) of the RI specification
element will be referred to as the 
\textit{set associated with the RI specification element}.
The type variables associated with the RI specification elements 
must be distinct and the type variables of the sets associated with the 
RI specification elements must be distinct.

The \textit{sbterm specification} is a finite sequence of 
pairs \mbox{$(t : ?\bar{\alpha}\ K,\ u : \bar{\beta}\ K)$}, 
where $t$ is either a constant-instance or a 
schematic typed term variable and $u$ is an sbterm with respect to $\Gamma$.
The individual elements of the sbterm specification will 
be referred to as the \textit{sbterm specification elements}.
Given an sbterm specification element, any term that 
occurs on the LHS of the sbterm specification element will be referred to as the 
\textit{tbt associated with the sbterm specification element},
any sbterm that occurs on the RHS of the 
sbterm specification element will be referred to as the 
\textit{sbterm associated with the sbterm specification element}.

The \textit{rewrite rules for the set-based theorem} can be any set
of valid rules for the Isabelle simplifier \cite{wenzel_isabelle/isar_2019-1};
the \textit{known premises for the set-based theorem} can be any finite 
sequence of deductions in $\Gamma$; the 
\textit{specification of the elimination of premises in the set-based theorem}
is a pair $(\bar{t}, m)$, where $\bar{t}$ is a sequence of formulae and $m$ 
is a proof method; the \textit{attributes for the set-based theorem} 
is a sequence of attributes of Isabelle (e.g., see \cite{wenzel_isabelle/isar_2019-1}).
›



subsection‹Definition of the ERA\label{sec:def-ERA}›


text‹
Assume that there exists a context $\Gamma$ and an ERA-parameterization 
for $\Gamma$. A valid input to the ERA is considered to be a theorem 
$\vdash\phi$ such that all variables
that occur in the theorem at the top level are schematic. 
It is also assumed that there exists a (possibly empty) sequence of 
schematic variables $?\bar{h}$ of length $m$ that form a subset 
of the schematic variables that occur in $\phi$ and a sequence 
$\bar{g}$ of sbterms in $\Gamma$ of the equivalent length, such that 
$(?\bar{h}_i, \bar{g}_i)$ is an sbterm specification element of 
the ERA-parameterization for all $i$ such that $1 \leq i \leq m$. 

In what follows, like in the exposition of the ORA in 
\cite{blanchette_types_2016} and the RA in subsection \ref{sec:ra}, 
for brevity it is assumed
that the set of the type variables that occur in $\phi$ is the singleton set 
$\{?\alpha_{\Upsilon}\}$, 
where $\Upsilon$ is a type class that depends on the sequence of
overloaded constants $\bar{*}$ of length $n$.
Thus, it is also assumed that the RI specification in the ERA-parameterization 
contains exactly one RI specification element 
$(?\alpha_{\Upsilon}, U_{\alpha\ \mathsf{set}})$
and that there exists a sequence of $n$ sbterms $\bar{f}$ in $\Gamma$ 
such that $(\bar{*}_i, \bar{f}_i)$ are sbterm specification elements 
of the ERA-parameterization for all $i$ such that $1 \leq i \leq n$. 
Lastly, it is assumed
that the set of all type variables of the sbterms associated with 
the sbterm specification elements of the ERA-parameterization 
is the singleton set $\{\alpha\}$, thence, there exist sequences $\bar{K}$
and $\bar{L}$ such that $\bar{h}_i : ?\alpha_{\Upsilon}\ \bar{K}_i$ and 
$\bar{g}_i : \alpha\ \bar{K}_i$ for all $i$ such that $1 \leq i \leq m$, and
$\bar{*}_i : ?\alpha_{\Upsilon}\ \bar{L}_i$ and 
$\bar{f}_i : \alpha\ \bar{L}_i$ for all $i$ such that $1 \leq i \leq n$. 

The ERA can be divided in three distinct parts: 
\textit{initialization of the relativization context},
\textit{kernel of the ERA} (KERA) and \textit{post-processing}.

\textbf{Initialization of the relativization context}.
Prior to the application of the relativization algorithm, the formula 
$\exists \mathsf{Rep}\ \mathsf{Abs}.\ {}_{\alpha}(\beta \approx U)_{\mathsf{Rep}}^{\mathsf{Abs}}$ 
is added to the context $\Gamma$, with the type variable $\beta$ being fresh 
for $\Gamma$:  
\mbox{$\Gamma' = \Gamma \cup \{\exists \mathsf{Rep}\ \mathsf{Abs}.\ {}_{\alpha}(\beta \approx U)_{\mathsf{Rep}}^{\mathsf{Abs}}\}$}.
In what follows, $\Gamma'$ will be referred to as the relativization context.
Then, the properties of the Hilbert choice $\varepsilon$ 
are used for the definition of $\mathsf{Rep}$ and
$\mathsf{Abs}$ such that \mbox{$\Gamma' \vdash {}_{\alpha}(\beta \approx U)_{\mathsf{Rep}}^{\mathsf{Abs}}$}
(e.g., see \cite{kuncar_types_2015}).
In this case,
\mbox{$(U_{\alpha\ \mathsf{set}},\beta,\mathsf{Rep}_{\beta\rightarrow\alpha},\mathsf{Abs}_{\alpha\rightarrow\beta})$} 
is an RI with respect to $\Gamma'$. 
Furthermore, a fresh $T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}}$ 
is defined as a transfer relation associated with the RI. Finally, the 
transfer domain rule associated with the RI and the side conditions associated
with the RI are proved for $T$ with respect to $\Gamma'$. 
For each $\bar{g}_i$ such that \mbox{$1 \leq i \leq m$},
the sbt-database contains a deduction
\mbox{$
\Gamma \vdash\mathsf{dbr}[?A, U] \longrightarrow
\exists a.\ R\left[?A\right]_{\alpha\ \bar{K}_i \rightarrow ?\delta\ \bar{K}_i\rightarrow \mathbb{B}}\ \bar{g}_i\ a,
$}.
Thence, for each $i$ such that $1 \leq i \leq m$, $?\delta$ is instantiated 
as $\beta$ and $?A_{\alpha\rightarrow?\delta\rightarrow\mathbb{B}}$ is instantiated 
as $T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}}$. The resulting theorems
are used for the definition of a fresh sequence $\bar{a}$ such that  
\mbox{$\Gamma' \vdash R\left[T_{\alpha\rightarrow\beta\rightarrow\mathbb{B}}\right]_{\alpha\ \bar{K}_i \rightarrow 
\beta\ \bar{K}_i\rightarrow \mathbb{B}}\ \bar{g}_i\ \bar{a}_i$}.
Similar deductions are also established for the sequence $\bar{f}$, with the 
sequence of the elements appearing on the RHS of the transfer rule denoted
by $\bar{b}$.
These deductions are meant to be used by the transfer infrastructure during the step of the ERA that
is equivalent to step 5 of the RA, as shown below.

\textbf{Kernel of the ERA}. The KERA is similar to the
the RA: 
\[
\scalebox{0.75}{
\infer[(7)]
{
\Gamma\vdash U \neq\emptyset\longrightarrow
U\downarrow\bar{g},\bar{f}\longrightarrow
\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ U\ \bar{f} \longrightarrow
\phi^{\mathsf{on}}_{\mathsf{with}}\left[\alpha,U,\bar{g},\bar{f}\right]
}
{
\infer[(6)]
{
\Gamma
\vdash \exists \mathsf{Rep}\ \mathsf{Abs}.{}_{\alpha}(\beta \approx U)_{\mathsf{Rep}}^{\mathsf{Abs}} 
\longrightarrow
U\downarrow\bar{g},\bar{f}\longrightarrow
\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ U\ \bar{f}\longrightarrow
\phi^{\mathsf{on}}_{\mathsf{with}}\left[\alpha,U,\bar{g},\bar{f}\right]
}
{
\infer[(5)]
{
\Gamma'
\vdash U\downarrow\bar{g},\bar{f}\longrightarrow
\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ U\ \bar{f}\longrightarrow
\phi^{\mathsf{on}}_{\mathsf{with}}\left[\alpha,U,\bar{g},\bar{f}\right]
}
{
\infer[(4)]
{
\Gamma'
\vdash\Upsilon_{\mathsf{with}}\ \bar{b}\longrightarrow
\phi_{\mathsf{with}}\left[\beta,\bar{a},\bar{b}\right]
}
{
\infer[(3)]
{
\Gamma'
\vdash\Upsilon_{\mathsf{with}}\ ?\bar{f}\left[\beta\right]\longrightarrow
\phi_{\mathsf{with}}\left[\beta,?\bar{h}\left[\beta\right],?\bar{f}\right]
}
{
\infer[(2)]
{
\Gamma'\vdash\Upsilon_{\mathsf{with}}\ ?\bar{f}\left[?\alpha\right]\longrightarrow
\phi_{\mathsf{with}}\left[?\alpha,?\bar{h}\left[?\alpha\right],?\bar{f}\right]
}
{
\infer[(1)]
{
\Gamma'\vdash\phi_{\mathsf{with}}\left[?\alpha_{\Upsilon}, ?\bar{h}\left[?\alpha_{\Upsilon}\right], \bar{*} \right]
}
{
\Gamma'\vdash\phi\left[?\alpha_{\Upsilon}, ?\bar{h}\left[?\alpha_{\Upsilon}\right]\right]
}
}
}
}
}
}
}
}
\]
Thus, step 1 will be referred to as the first step of the dictionary 
construction (similar to step 1 of the RA);
step 2 will be referred to as unoverloading of the type $?\alpha_{\Upsilon}$: 
it includes class internalization and the application of the UO 
(similar to step 2 of the RA); 
in step 3, $?\alpha$ is 
instantiated as $\beta$ using the RI specification 
(similar to step 4 in the RA); 
in step 4, the sbterm specification is used for the instantiation
of $?\bar{h}$ as $\bar{a}$ and $?\bar{f}$ as $\bar{b}$; 
step 5 refers to the application of transfer, including the
transfer rules associated with the sbterms
(similar to step 5 in the RA); in step 6, the result is exported from $\Gamma'$ 
to $\Gamma$, providing the additional premise 
$\exists \mathsf{Rep}\ \mathsf{Abs}.\ {}_{\alpha}(\beta \approx U)_{\mathsf{Rep}}^{\mathsf{Abs}}$;
step 7 is the application of the attribute
@{attribute cancel_type_definition}
(similar to step 6 in the RA).

The RI specification and the sbterm specification provide the information
that is necessary to perform the type and term substitutions in steps
3 and 4 of the KERA. If the specifications are viewed as finite maps, 
their domains morph along the transformations that the theorem 
undergoes until step 4. 

\textbf{Post-processing}. The deduction that is obtained in the final step of 
the KERA can often be simplified further.
The following post-processing steps were created to allow for the presentation 
of the set-based theorem in a format that is both desirable and convenient for 
the usual applications:
\begin{enumerate}
\item \textit{Simplification}. The 
rewriting is performed using the rewrite rules for the set-based theorem:
the implementation relies on the functionality of Isabelle's simplifier.
\item \textit{Substitution of known premises}. The known premises for the 
set-based theorem are matched with the premises of the set-based theorem, allowing 
for their elimination.
\item \textit{Elimination of premises}. 
Each premise is matched against each term 
in the specification of the elimination of premises in the set-based theorem; 
the associated method is applied in an attempt to eliminate 
the matching premises (this can be useful for the 
elimination of the premises of the form $U \neq \emptyset$).
\item \textit{Application of the attributes for the set-based theorem}. 
The attributes for the set-based theorem are applied as the 
final step during post-processing.
\end{enumerate}

Generally, the desired form of the result after a successful application 
of post-processing is similar to
\mbox{$\Gamma\vdash\phi^{\mathsf{on}}_{\mathsf{with}}\left[\alpha,U,\bar{g},\bar{f}\right]$}
with the premises \mbox{$U \neq \emptyset$, $U\downarrow\bar{g},\bar{f}$} and 
\mbox{$\Upsilon^{\mathsf{on}}_{\mathsf{with}}\ U\ \bar{f}$} eliminated completely (these premises
can often be inferred from the context $\Gamma$).
›

text‹\newpage›

end

Theory ETTS_Syntax

(* Title: ETTS/Manual/ETTS_Syntax.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

section‹Syntax›
theory ETTS_Syntax
  imports ETTS_Theory
begin



subsection‹Background›


text ‹
This section presents the syntactic categories that are associated with the 
commands @{command tts_context}, @{command tts_lemmas}, @{command tts_lemma}, 
and several other closely related auxiliary commands. 
It is important to note that the presentation of the syntax is approximate.
›



subsection‹Registration of the set-based terms›

text‹

\begin{matharray}{rcl}
  @{command_def "tts_register_sbts"} & : & local_theory → proof(prove)› \\
  @{command_def "tts_find_sbts"} & : & context →›
\end{matharray}

  

  rail@@{command tts_register_sbts} term @'|' (term + @'and')
    ;
    @@{command tts_find_sbts} (term + @'and')
  ›

   tts_register_sbts t› |› U1 and …› and Un allows for the
registration of the set-based terms in the sbt-database.  
Generally, Ui (1≤i≤n›) must be distinct fixed variables with distinct types 
of the form typ'a set›, with the set of the type variables that occur in the 
types of Ui equivalent to the set of the type variables that occur in 
the type of t›.

   tts_find_sbts t1 and …› and tn prints the 
templates for the transfer rules for the set-based terms t1…tn.  

›



subsection‹Relativization of theorems›


text‹

\begin{matharray}{rcl}
  @{command_def "tts_context"} & : & theory → local_theory› \\
  @{command_def "tts_lemmas"} & : & local_theory → local_theory› \\
  @{command_def "tts_lemma"} & : & local_theory → proof(prove)› \\
  @{command_def "tts_theorem"} & : & local_theory → proof(prove)› \\
  @{command_def "tts_corollary"} & : & local_theory → proof(prove)› \\
  @{command_def "tts_proposition"} & : & local_theory → proof(prove)› \\
\end{matharray}

The relativization of theorems should always be performed inside an 
appropriately parameterized tts context. The tts context can be set up
using the command @{command tts_context}. The framework introduces two
types of interfaces for the application of the extended relativization
algorithm: @{command tts_lemmas} and the family of the commands with
the identical functionality: @{command tts_lemma}, @{command tts_theorem}, 
@{command tts_corollary}, @{command tts_proposition}. Nonetheless,
the primary purpose of the command @{command tts_lemmas} is the
experimentation and the automated generation of the relativized results stated 
using the command @{command tts_lemma}. 

  

  rail@@{command tts_context} param @'begin'
    ;
    @@{command tts_lemmas} ((@'!' | @'?')?) tts_facts
    ;
    (
      @@{command tts_lemma} |
      @@{command tts_theorem} |
      @@{command tts_corollary} |
      @@{command tts_proposition}
    )
    (tts_short_statement | tts_long_statement)
    ;
    param: (sets var rewriting subst eliminating app)
    ;
    sets: (@'tts' @':' ('(' type_var @'to' term ')' + @'and'))
    ;
    var: (@'sbterms' @':' vars)?
    ;
    vars: ('(' term @'to' term ')' + @'and')
    ;
    rewriting: (@'rewriting' thm)?
    ;
    subst: (@'substituting' (thm + @'and'))?
    ;
    eliminating: (@'eliminating' elpat? @'through' method)?
    ;
    elpat: (term + @'and')
    ;
    app: (@'applying' attributes)?
    ;
    tts_short_statement: short_statement tts_addendum
    ;
    tts_long_statement: thmdecl? context tts_conclusion
    ;
    tts_conclusion: 
      (
        @'shows' (props tts_addendum + @'and') | 
        @'obtains' obtain_clauses tts_addendum
      )
    ;
    tts_addendum: (@'given' thm | @'is' thm)
    ;
    tts_facts: @'in' (thmdef? thms + @'and')
    ;

   tts_context param begin provides means for the specification of a
new (unnamed) tts context.
     @{element "tts"}~:›~(?a1 to U1)› and …› and 
(?an to Un)› provides means for the declaration of the RI specification. 
For each i› (1≤i≤n›), ?ai must be a schematic type variable that
occurs in each theorem provided as an input to the commands
@{command tts_lemmas} and @{command tts_lemma} invoked inside the tts context
and Ui can be any term of the type typ'a set›, where typ'a 
is a fixed type variable.
     @{element "sbterms"}~:›~(tbcv1 to sbt1)› and …› and
(tbcvn to sbtn)› can be used for the declaration of the 
sbterm specification.
For each individual entry i›, such that 1≤i≤n›, tbcvi has to be either an
overloaded operation that occurs in every theorem that is provided as an input
to the extended relativization algorithm or a schematic variable that occurs in
every theorem that is provided as an input to the command, and sbti has to be
a term registered in the sbt-database.
     @{element "rewriting"} thm› provides means for the declaration
of the rewrite rules for the set-based theorem.
     @{element "substituting"} thm1 and …› and thmn provides
means for the declaration of the known premises for the set-based theorem.
     @{element "eliminating"} term1 and …› and termn 
@{element "through"} method› provides means for the declaration of
the specification of the elimination of premises in the set-based theorem.
     @{element "applying"} [attr1, …, attrn]› provides means for 
the declaration of the attributes for the set-based theorem.

   tts_lemmas applies the ERA to a list 
of facts and saves the resulting set-based facts in the context. 
The command @{command tts_lemmas} should always be invoked from within a 
tts context. If the statement of the command is followed immediately by the
optional keyword @{element "!"}, then it operates in the verbose mode, 
printing the output of the application of the individual steps of the 
programmatic implementation of the algorithm. If the statement of the command 
is followed immediately by the optional keyword @{element "?"}, then 
the command operates in the active mode, outputting the set-based facts
in the form of the ``active areas'' that can be embedded in the Isabelle 
theory file inside the tts context from which the command @{command tts_lemmas}
was invoked. There is a further minor difference between the active mode
and the other two modes of operation that is elaborated upon within the 
description of the keyword @{element "in"} below. 

     @{element "in"} sbf1 = tbf1 and …› and sbfn = tbfn is used for
the specification of the type-based theorems and the output of the command.
For each individual entry i›, such that 1≤i≤n›, tbfi is used for
the specification of the input of the extended relativization algorithm and
sbfi is used for the specification of the name binding for the output of
the extended relativization algorithm.
The specification of the output is optional: if sbfi is omitted, then a 
default specification of the output is inferred automatically. tbfi must 
be a schematic fact available in the context, whereas sbfi can be any
fresh name binding. Optionally, it is possible to provide attributes for 
each individual input and output, e.g., sbfi[sbf_attrb] = tbfi[tbf_attrb]›. 
In this case, the list of the attributes tbf_attrb› is applied to tbfi 
during the first part (initialization of the relativization context) 
of the ERA. If the command operates in the active
mode, then the attributes sbf_attrb› are included in the active area output,
but not added to the list of the set-based attributes.
For other modes of operation, the attributes sbf_attrb› are added to the list 
of the set-based attributes and applied during the third part (post-processing) 
of the ERA. 

   tts_lemma~a: φ› @{syntax "tts_addendum"}, enters proof mode with 
the main goal formed by an application of a tactic that depends on the 
settings specified in @{syntax "tts_addendum"} to φ›. Eventually, this results 
in some fact ⊢φ› to be put back into the target context. The command
should always be invoked from within a tts context. 

     A @{syntax tts_long_statement} is similar to the standard  
@{syntax long_statement} in that it allows to build up an initial proof 
context for the subsequent claim incrementally. Similarly, 
@{syntax tts_short_statement} can be viewed as a natural extension of the 
standard @{syntax short_statement}.  

     @{syntax "tts_addendum"} is used for the specification of the 
pre-processing strategy of the goal φ›. \mbox{φ› is thm›} applies the 
extended relativization algorithm to thm›. If the term that is associated 
with the resulting set-based theorem is α›-equivalent to the term associated 
with the goal φ›, then a specialized tactic solves the main goal, leaving
only a trivial goal in its place (the trivial goal can be solved using the
terminal proof \mbox{step \textbf{.}}). \mbox{φ› given thm›} also applies the 
extended relativization algorithm to thm›, but the resulting set-based theorem
is merely added as a premise to the goal φ›. 
›

text‹\newpage›

end

Theory ETTS_Examples

(* Title: ETTS/Manual/ETTS_Examples.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)


section‹ETTS by example›
theory ETTS_Examples
  imports 
    ETTS_Syntax
    Complex_Main
begin



subsection‹Background›


text‹
In this section, some of the capabilities of the extension of the framework
Types-To-Sets are demonstrated by example. The examples that are presented 
in this section are expected to be sufficient to begin an independent 
exploration of the extension, but do not cover the entire spectrum of its 
functionality.
›



subsection‹First steps›


subsubsection‹Problem statement›


text‹
Consider the task of the relativization of the type-based theorem 
@{thm [source] topological_space_class.closed_Un} from the standard library
of Isabelle/HOL:
\begin{center}
@{thm [names_short = true] topological_space_class.closed_Un[no_vars]},
\end{center}
where S::'a::topological_space set› and T::'a::topological_space set›.
›


subsubsection‹Unoverloading›


text‹
The constant @{const closed} that occurs in the theorem is an overloaded
constant defined as \mbox{@{thm [names_short = true] closed_def[no_vars]}}
for any @{term [show_sorts] "S::'a::topological_space set"}. 
The constant may be unoverloaded with 
the help of the command @{command ud} that is provided as part of 
the framework ``Conditional Transfer Rule'' (CTR):
›
ud ‹topological_space.closed›
ud closed' ‹closed›
text‹
This invocation declares the constant @{const closed.with} that is defined as
\begin{center}
@{thm closed.with_def[no_vars]}
\end{center}
and provides the theorem @{thm [source] closed.with}
\begin{center}
@{thm closed.with[no_vars]}
\end{center}
that establishes the relationship between the unoverloaded constant
and the overloaded constant. The theorem @{thm [source] closed.with}
is automatically added to the dynamic fact @{thm [source] ud_with}.
›


subsubsection‹Conditional transfer rules›


text‹
Before the relativization can be performed, the transfer rules need to be 
available for each constant that occurs in the type-based theorem 
immediately after step 4 of the KERA. 
All binary relations that are used in the transfer rules must be 
at least right total and bi-unique (assuming the default order on predicates in 
Isabelle/HOL). For the theorem 
@{thm [source] topological_space_class.closed_Un}, there are two such constants:
@{const class.topological_space} and @{const closed.with}.
The transfer rules can be obtained with the help of the command @{command ctr} 
from the framework CTR. The process may involve
the synthesis of further ``relativized'' constants, as described in the
reference manual for the framework CTR.
›
ctr
  relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "right_total A" "bi_unique A"
  trp (?'a A)
  in topological_space_ow: class.topological_space_def
    and closed_ow: closed.with_def


subsubsection‹Relativization›


text‹
As mentioned previously, the relativization of theorems can only
be performed from within a suitable tts context. In setting up the tts context,
the users always need to provide the RI specification elements that are 
compatible with the theorems that are meant to be relativized in the 
tts context. The set of the schematic type variables that occur in the theorem 
@{thm [source] topological_space_class.closed_Un} is {›?'a›}›. 
Thus, there needs to be exactly one RI specification element of the form 
(?'a›, @{term [show_types] "U::'a set"}):
›
tts_context
  tts: (?'a to U::'a set›)
begin

text‹
The relativization can be performed by invoking the command 
@{command tts_lemmas} in the following manner:
›
tts_lemmas? in closed_Un' = topological_space_class.closed_Un
text‹
In this case, the command was invoked in the active mode, providing
an active area that can be used to insert the following theorem directly
into the theory file:
›

tts_lemma closed_Un':
  assumes "U  {}"
    and "xS. x  U"
    and "xT. x  U"
    and "topological_space_ow U opena"
    and "closed_ow U opena S"
    and "closed_ow U opena T"
  shows "closed_ow U opena (S  T)"
    is topological_space_class.closed_Un.

text‹
The invocation of the command @{command tts_lemmas} in the
active mode can be removed with no effect on the theorems that 
were generated using the command.
›

end

text‹
While our goal was achieved, that is, the theorem 
@{thm [source] closed_Un'} is, indeed, a relativization
of the theorem @{thm [source] topological_space_class.closed_Un},
something does not appear right. Is the assumption U ≠ {}› necessary?
Is it possible to simplify ∀x∈S. x ∈ U›? Is it necessary to 
use the such contrived name for the denotation of an open set? 
Of course, all of these 
issues can be resolved by restating the theorem in the form that we would like 
to see and using @{thm [source] closed_Un'} in the proof of this theorem, 
e.g.
›
lemma closed_Un'':
  assumes "S  U"
    and "T  U"
    and "topological_space_ow U τ"
    and "closed_ow U τ S"
    and "closed_ow U τ T"
  shows "closed_ow U τ (S  T)"
  using assms
  unfolding topological_space_ow_def 
  by (cases U = {}) (auto simp: assms(3) closed_Un' subset_iff)
text‹
However, having to restate the theorem presents a grave inconvenience.
This can be avoided by using a different format of the @{syntax tts_addendum}:
›
tts_context
  tts: (?'a to U::'a set›)
begin

tts_lemma closed_Un''':
  assumes "S  U"
    and "T  U"
    and "topological_space_ow U τ"
    and "closed_ow U τ S"
    and "closed_ow U τ T"
  shows "closed_ow U τ (S  T)"
    given topological_space_class.closed_Un    
proof(cases U = {})
  case False assume prems[OF False]:
    " 
      U  {}; 
      xS. x  U;
      xT. x  U; 
      topological_space_ow U τ;  
      closed_ow U τ S;
      closed_ow U τ T 
       closed_ow U τ (S  T)"
    for U :: "'a set" and S T τ
  from prems show ?thesis using assms by blast
qed simp
  
end
text‹
Nevertheless, could there still be some space for improvement? 
It turns out that instead of having to state
the theorem in the desired form manually, often enough, it suffices 
to provide additional parameters for post-processing
of the raw set-based theorem, as demonstrated in the code below:
›
tts_context
  tts: (?'a to U::'a set›)
  rewriting ctr_simps
  eliminating ?U{} through (auto simp: topological_space_ow_def)
  applying[of _ _ _ τ]
begin

tts_lemma closed_Un'''':
  assumes "S  U"
    and "T  U"
    and "topological_space_ow U τ"
    and "closed_ow U τ S"
    and "closed_ow U τ T"
  shows "closed_ow U τ (S  T)"
    is topological_space_class.closed_Un.

end

text‹
Finding the most suitable set of parameters for post-processing of the 
result of the relativization is an iterative process and requires practice 
before fluency can be achieved.
›

text‹\newpage›

end

Theory ETTS_CR

(* Title: ETTS/Manual/ETTS_CR.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

theory ETTS_CR
  imports ETTS_Examples 
begin
end

Theory Introduction

(* Title: Examples/Introduction.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)

chapter‹ETTS Case Studies: Introduction›
theory Introduction
  imports Types_To_Sets_Extension.ETTS_Auxiliary
begin




section‹Background›



subsection‹Purpose›


text‹
The remainder of this document presents several examples of the application 
of the extension of the framework Types-To-Sets and provides the potential 
users of the extension with a plethora of design 
patterns to choose from for their own applied relativization needs. 
›



subsection‹Related work›


text‹

Since the publication of the framework Types-To-Sets in
\cite{blanchette_types_2016}, there has been a growing interest
in its use in applied formalization. Some 
of the examples of the application of the framework include
\cite{divason_perron-frobenius_2016}, 
\cite{maletzky_hilberts_2019} and \cite{immler_smooth_2019}. However, this
list is not exhaustive. Arguably, the most significant application example 
was developed in \cite{immler_smooth_2019}, where Fabian Immler and
Bohua Zhan performed the 
relativization of over 200 theorems from the standard mathematics library
of Isabelle/HOL.

Nonetheless, it is likely that the work presented in this document 
is the first significant application of the ETTS: 
unsurprisingly, the content this document was developed 
in parallel with the extension of the framework itself. Also, perhaps, it is
the largest application of the framework Types-To-Sets up to this date: 
only one of the three libraries (SML Relativization) presented in the 
context of this work contains the relativization of over 800 theorems 
from the standard library of Isabelle/HOL.
›




section‹Examples: overview›



subsection‹Background›


text‹
The examples that are presented in this document were developed for the 
demonstration of the impact of various aspects of the relativization process 
on the outcome of the relativization. 
Three libraries of relativized results were developed in the context 
of this work:
\begin{itemize}
\item \textit{SML Relativization}: a relativization 
of elements of the standard mathematics library of Isabelle/HOL
\item \textit{TTS Vector Spaces}: a renovation of the set-based
library that was developed in \cite{immler_smooth_2019} using the ETTS
instead of the existing interface for Types-To-Sets
\item \textit{TTS Foundations}: a relativization of a miniature type-based 
library with every constant being parametric under the side
conditions compatible with Types-To-Sets
\end{itemize}
›



subsection‹SML Relativization›


text‹
The standard library that is associated with the 
object logic Isabelle/HOL and provided as a part of the 
standard distribution of Isabelle \cite{noauthor_isabellehol_2020} 
contains a significant number of formalized results from a variety of 
fields of mathematics. However, the formalization is performed using a 
type-based approach: for example, the carrier sets associated with the 
algebraic structures and the underlying sets of the topological spaces 
consist of all terms of an arbitrary type.
The ETTS was applied to the relativization of a certain number of results from 
the standard library.

The results that are formalized in the library 
SML Relativization are taken from an array of topics that include 
order theory, group theory, ring theory and topology.
However, only the
results whose relativization could be nearly fully automated using 
the frameworks UD, CTR and ETTS with almost no additional proof effort
are included.
›



subsection‹TTS Vector Spaces›


text‹
The TTS Vector Spaces is a remake of the library of relativized results that 
was developed in \cite{immler_smooth_2019} using the ETTS.
The theorems that are provided in the library TTS Vector Spaces are nearly 
identical to the results that are provided in \cite{immler_smooth_2019}. 

A detailed description of the original library has already
been given in \cite{immler_smooth_2019} and will not be restated.
The definitional frameworks that are used in \cite{immler_smooth_2019}
and the TTS Vector Spaces are similar. While the unoverloading 
of most of the constants could be performed by using the 
command @{command ud}, the command @{command ctr} could not 
be used to establish that the unoverloaded constants are 
parametric under a suitable set of side conditions. Therefore,
like in \cite{immler_smooth_2019}, the proofs of the transfer rules were 
performed manually. However, the advantages 
of using the ETTS become apparent during the relativization of 
theorems: the complex infrastructure that was needed for 
compiling out dependencies on overloaded constants, the manual invocation of the 
attributes related to the individual steps of the relativization algorithm, 
the repeated explicit references to the theorem as it undergoes the 
transformations associated with the individual steps of 
a the relativization algorithm, the explicitly stated names of the set-based 
theorems were no longer needed. Furthermore, the theorems synthesized by the 
ETTS in TTS Vector Spaces appear in the formal proof documents in a format 
that is similar to the canonical format of the Isabelle/Isar declarations
associated with the standard commands such as @{command lemma}.
›



subsection‹TTS Foundations›


text‹
The most challenging aspect of the relativization
process, perhaps, is related to the availability of the transfer rules for the
constants in the type-based theorems. Nonetheless, even if the transfer 
rules are available, having to use the relativized constants in the set-based 
theorems that are different from the original constants that are used in the 
type-based theorems can be seen as unnatural and inconvenient. 
Unfortunately, the library SML Relativization suffers from both 
of the aforementioned problems. The library that was 
developed in \cite{immler_smooth_2019} 
(hence, also the library TTS Vector Spaces) 
suffers, primarily, from the former problem, but, arguably, due to the methodology
that was chosen for the relativization, the library has a more restricted scope
of applicability.

The library TTS Foundations provides an example of a miniature 
type-based library such that all constants associated with the operations on
mathematical structures (effectively, this excludes the
constants associated with the locale predicates) 
in the library are parametric under the side conditions 
compatible with Types-To-Sets. The relativization is 
performed with respect to all possible type variables; in this case,
the type classes are not used in the type-based library. Currently,
the library includes the results from the areas of order theory and
semigroups. However, it is hoped that it can be seen
that the library can be easily extended to include most of the
content that is available in the main library of Isabelle/HOL.

The library TTS Foundations demonstrates that the development of a 
set-based library can be nearly fully automated using the 
existing infrastructure associated with the UD, CTR and ETTS, 
and requires almost no explicit proofs on
behalf of the users of these frameworks.›

end

Theory SML_Introduction

(* Title: Examples/SML_Relativization/SML_Introduction.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
chapter‹SML Relativization›
theory SML_Introduction
  imports "../Introduction"
begin
end

Theory Set_Ext

(* Title: Examples/SML_Relativization/Foundations/Set_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Extension of the theory text‹Set›
theory Set_Ext
  imports Main
begin

lemma set_comp_pair: "{f t r |t r. P t r} = {x. t r. P t r  x = (f t r)}"
  by auto

lemma image_iff': "(xA. f x  B) = (f ` A  B)" by auto

text‹\newpage›

end

Theory Lifting_Set_Ext

(* Title: Examples/SML_Relativization/Foundations/Lifting_Set_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Extension of the theory text‹Lifting_Set›
theory Lifting_Set_Ext
  imports Main
begin

context
  includes lifting_syntax
begin

lemma set_pred_eq_transfer[transfer_rule]:
  assumes "right_total A" 
  shows
    "((rel_set A ===> (=)) ===> (rel_set A ===> (=)) ===> (=)) 
      (λX Y. sCollect (Domainp A). X s = Y s) 
      ((=)::['b set  bool, 'b set  bool]  bool)"
proof(intro rel_funI)
  let ?sA = "Collect (Domainp A)"
  fix X Y :: "'a set  bool" 
  fix X' Y' :: "'b set  bool"
  assume rs: "(rel_set A ===> (=)) X X'" "(rel_set A ===> (=)) Y Y'"
  show "(s?sA. X s = Y s) = (X' = Y')"
  proof
    assume X_eq_Y: "s?sA. X s = Y s"
    {
      fix s' assume "X' s'" 
      then obtain s where "rel_set A s s'" 
        by (meson assms right_total_def right_total_rel_set)
      then have "X s" using rs(1) unfolding rel_fun_def by (simp add: X' s')
      moreover from ‹rel_set A s s' have "s  ?sA" 
        unfolding Ball_Collect[symmetric] by (auto dest: rel_setD1)
      ultimately have "Y' s'" 
        using rs(2)[unfolded rel_fun_def] ‹rel_set A s s' by (simp add: X_eq_Y)
    }
    note XY = this
    {
      fix s' assume "Y' s'" 
      then obtain s where "rel_set A s s'" 
        by (meson assms right_total_def right_total_rel_set)
      then have "Y s" using rs(2)[unfolded rel_fun_def] by (simp add: Y' s')
      moreover from ‹rel_set A s s' have "s  ?sA" 
        unfolding Ball_Collect[symmetric] by (auto dest: rel_setD1)
      ultimately have "X' s'" 
        using X_eq_Y rs(1)[unfolded rel_fun_def] ‹rel_set A s s' by auto
    }
    with XY show "X' = Y'" by auto
  next
    assume "X' = Y'" show "s?sA. X s = Y s"
      unfolding Ball_Collect[symmetric]
      using rs[unfolded rel_fun_def] X' = Y' by (metis DomainpE Domainp_set)+
  qed
qed

private lemma vimage_fst_transfer_h:
  "
  pred_prod (Domainp A) (Domainp B) x = 
    (x  Collect (Domainp A) × Collect (Domainp B))
  "
  unfolding pred_prod_beta mem_Times_iff by simp

lemma vimage_fst_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique A" "right_total A" "right_total B" 
  shows 
    "((rel_prod A B ===> A) ===> rel_set A ===> rel_set (rel_prod A B)) 
      (λf S. (f -` S)  ((Collect (Domainp A)) × (Collect (Domainp B)))) 
      vimage"
  unfolding vimage_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding vimage_fst_transfer_h 
  by auto

lemma vimage_snd_transfer[transfer_rule]: 
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B" 
  shows 
    "((rel_prod A B ===> B) ===> rel_set B ===> rel_set (rel_prod A B)) 
      (λf S. (f -` S)  ((Collect (Domainp A)) × (Collect (Domainp B)))) 
      vimage"
  unfolding vimage_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding vimage_fst_transfer_h by auto

lemma vimage_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique B" "right_total A" 
  shows 
    "((A ===> B) ===> (rel_set B) ===> rel_set A) 
      (λf s. (vimage f s)  (Collect (Domainp A))) (-`)"
  by transfer_prover

lemma pairwise_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> A ===> (=)) ===> rel_set A  ===> (=)) pairwise pairwise"
  unfolding pairwise_def by transfer_prover

lemma disjnt_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A  ===> (=)) disjnt disjnt"
  unfolding disjnt_def by transfer_prover

lemma bij_betw_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "bi_unique B"
  shows "((A ===> B) ===> rel_set A ===> rel_set B ===> (=)) bij_betw bij_betw"
  unfolding bij_betw_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

text‹\newpage›

end

Theory Product_Type_Ext

(* Title: Examples/SML_Relativization/Foundations/Product_Type_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Extension of the theory text‹Product_Type_Ext›
theory Product_Type_Ext
  imports Main
begin

context
  includes lifting_syntax
begin

lemma Sigma_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows 
    "(rel_set A ===> (A ===> rel_set B) ===> rel_set (rel_prod A B))
      Sigma Sigma"
  unfolding Sigma_def by transfer_prover

end

text‹\newpage›

end

Theory Transfer_Ext

(* Title: Examples/SML_Relativization/Foundations/Transfer_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Extension of the theory text‹Transfer›
theory Transfer_Ext
  imports Main
begin

lemma bi_unique_intersect_r:
  assumes "bi_unique T" 
    and "rel_set T a a'" 
    and "rel_set T b b'" 
    and "rel_set T (a  b) xr" 
  shows "a'  b' = xr"
proof -
  {
    fix x assume "x  a  b"
    then have "x  a" and "x  b" by simp+
    from assms(2) x  a have "y  a'. T x y" by (rule rel_setD1)
    moreover from assms(3) x  b have "y  b'. T x y" by (rule rel_setD1)
    ultimately have "y  a'  b'. T x y" 
      using assms(1) by (auto dest: bi_uniqueDr)
  }
  note unique_r = this
  {
    fix x assume "x  a'  b'"
    then have "x  a'" and "x  b'" by simp+
    from assms(2) x  a' have "y  a. T y x" by (rule rel_setD2)
    moreover from assms(3) x  b' have "y  b. T y x" by (rule rel_setD2)
    ultimately have "y  a  b. T y x" 
      using assms(1) by (auto dest: bi_uniqueDl)
  }
  with unique_r have "rel_set T (a  b) (a'  b')" using rel_setI by blast 
  with assms(1,4) show ?thesis by (auto dest: bi_uniqueDr bi_unique_rel_set)
qed

lemma bi_unique_intersect_l:
  assumes "bi_unique T" 
    and "rel_set T a a'" 
    and "rel_set T b b'" 
    and "rel_set T xl (a'  b')" 
  shows "a  b = xl"
proof -
  let ?T' = "λ y x. T x y"
  from assms(1) have "bi_unique ?T'" unfolding bi_unique_def by simp
  moreover from assms(2) have "rel_set ?T' a' a" unfolding rel_set_def by simp
  moreover from assms(3) have "rel_set ?T' b' b" unfolding rel_set_def by simp
  moreover from assms(4) have "rel_set ?T' (a'  b') xl" 
    unfolding rel_set_def by simp
  ultimately show ?thesis by (rule bi_unique_intersect_r)
qed

lemma bi_unique_intersect:
  assumes "bi_unique T" and "rel_set T a a'" and "rel_set T b b'" 
  shows "rel_set T (a  b) (a'  b')" 
proof -
  {
    fix xl assume "xl  a  b"
    then have "xl  a" and "xl  b" by simp+
    with assms(3) obtain xr where "T xl xr" unfolding rel_set_def by auto
    with assms(1,2) xl  a have "xr  a'"
      by (auto dest: bi_uniqueDr rel_setD1)
    moreover with assms(1,3) xl  b T xl xr have "xr  b'" 
      by (auto dest: bi_uniqueDr rel_setD1)
    ultimately have "xr  a'  b'" by simp
    with T xl xr have "xr. xr  a'  b'  T xl xr" by auto
  }
  then have prem_lhs: "xl  a  b. xr. xr  a'  b'  T xl xr" by simp  
  {
    fix xr
    assume "xr  a'  b'"
    then have "xr  a'" and "xr  b'" by simp+
    with assms(3) obtain xl where "T xl xr" unfolding rel_set_def by auto
    with assms(1,2) xr  a' have "xl  a" 
      by (auto dest: bi_uniqueDl rel_setD2)
    moreover with assms(1,3) xr  b' T xl xr have "xl  b" 
      by (auto dest: bi_uniqueDl rel_setD2)
    ultimately have "xl  a  b" by simp
    with T xl xr have "xl. xl  a  b  T xl xr" by auto
  }
  then have prem_rhs: "xr  a'  b'. xl. xl  a  b  T xl xr" by simp
  from prem_lhs prem_rhs show ?thesis unfolding rel_set_def by auto
qed

lemma bi_unique_union_r:
  assumes "bi_unique T" 
    and "rel_set T a a'" 
    and "rel_set T b b'" 
    and "rel_set T (a  b) xr" 
  shows "a'  b' = xr"
proof -
  {
    fix x assume "x  a  b"
    then have "x  a  x  b" by simp
    from assms(2) have "y  a'. T x y" if "x  a" 
      using that by (rule rel_setD1)
    moreover from assms(3) have "y  b'. T x y" if "x  b" 
      using that by (rule rel_setD1)
    ultimately have "y  a'  b'. T x y" using x  a  x  b by auto
  }
  note unique_r = this
  {
    fix x assume "x  a'  b'"
    then have "x  a'  x  b'" by simp
    from assms(2) have "y  a. T y x" if "x  a'" 
      using that by (rule rel_setD2)
    moreover from assms(3) have "y  b. T y x" if "x  b'" 
      using that by (rule rel_setD2)
    ultimately have "y  a  b. T y x" using x  a'  x  b' by auto
  }
  with unique_r have "rel_set T (a  b) (a'  b')" by (auto intro: rel_setI) 
  with assms(1,4) show ?thesis by (auto dest: bi_uniqueDr bi_unique_rel_set)
qed

lemma bi_unique_union_l:
  assumes "bi_unique T" 
    and "rel_set T a a'" 
    and "rel_set T b b'" 
    and "rel_set T xl (a'  b')" 
  shows "a  b = xl"
proof -
  let ?T' = "λy x. T x y"
  from assms(1) have "bi_unique ?T'" unfolding bi_unique_def by simp
  moreover from assms(2) have "rel_set ?T' a' a" unfolding rel_set_def by simp
  moreover from assms(3) have "rel_set ?T' b' b" unfolding rel_set_def by simp
  moreover from assms(4) have "rel_set ?T' (a'  b') xl" 
    unfolding rel_set_def by simp
  ultimately show ?thesis by (rule bi_unique_union_r)
qed

lemma bi_unique_union:
  assumes "bi_unique T" and "rel_set T a a'" and "rel_set T b b'" 
  shows "rel_set T (a  b) (a'  b')" 
proof -
  {
    fix xl assume "xl  a  b"
    with assms(2,3) obtain xr where "T xl xr" unfolding rel_set_def by auto
    with assms xl  a  b have "xr  a'  b'"
      unfolding bi_unique_def using Un_iff by (metis Un_iff rel_setD1)
    with T xl xr have "xr. xr  a'  b'  T xl xr" by auto
  }
  then have prem_lhs: "xl  a  b. xr. xr  a'  b'  T xl xr" by simp  
  {
    fix xr assume "xr  a'  b'"
    with assms(2,3) obtain xl where "T xl xr" unfolding rel_set_def by auto
    with assms xr  a'  b' have "xl  a  b"
      unfolding bi_unique_def by (metis Un_iff rel_setD2)
    with T xl xr have "xl. xl  a  b  T xl xr" by auto
  }
  then have prem_rhs: "xr  a'  b'. xl. xl  a  b  T xl xr" by simp
  from prem_lhs prem_rhs show ?thesis unfolding rel_set_def by auto
qed

lemma bi_unique_Union_r:
  fixes T :: "['a, 'b]  bool" and K
  defines K':  "K'  {(x, y). rel_set T x y} `` K"
  assumes "bi_unique T" 
    and "K  Collect (Domainp T)" 
    and "rel_set T (K) xr" 
  shows "K' = xr"
proof -
  {
    fix x assume "x  K"
    then obtain k where "x  k" and "k  K" by clarsimp
    from assms have ex_k'_prem: "k  K. x  k. x'. T x x'" by auto
    define k' where k': "k' = {x'. x  k. T x x'}" 
    have "rel_set T k k'" 
      unfolding rel_set_def Bex_def k' 
      using k  K by (blast dest: ex_k'_prem[rule_format])
    with k  K have "k'  K'" unfolding K' by auto
    from ‹rel_set T k k' x  k obtain y where "y  k'  T x y" 
      by (auto dest: rel_setD1)
    then have "y  K'. T x y" using k'  K' by auto
  }
  note unique_r = this
  {
    fix x' assume "x'  K'"
    then obtain k' where "x'  k'" and "k'  K'" by clarsimp
    then have ex_k_prem: "k'  K'. x  k'. x. T x x'" 
      unfolding K' by (auto dest: rel_setD2)
    define k where k: "k = {x. x'  k'. T x x'}"
    have "rel_set T k k'" 
      unfolding rel_set_def Bex_def k 
      using k'  K' K' by (blast dest: rel_setD2)
    from assms(2) have "bi_unique (rel_set T)" by (rule bi_unique_rel_set)
    with ‹rel_set T k k' have "∃!k. rel_set T k k'" by (auto dest: bi_uniqueDl)
    with ‹rel_set T k k' K' k'  K' have "k  K" by auto
    from ‹rel_set T k k' x'  k' obtain y where "y  k  T y x'" 
      by (auto dest: rel_setD2)
    then have "y  K. T y x'" using k  K by auto
  }
  with unique_r have "rel_set T (K) (K')" by (intro rel_setI) 
  with assms(2,4) show ?thesis by (auto dest: bi_uniqueDr bi_unique_rel_set)
qed

lemma bi_unique_Union_l:
  fixes T :: "['a, 'b]  bool" and K'
  defines K: "K  {(x, y). rel_set (λ y x. T x y) x y} `` K'"
  assumes "bi_unique T" 
    and "K'  Collect (Rangep T)" 
    and "rel_set T xl (K')" 
  shows "K = xl"
proof -
  let ?T' = "λ y x. T x y"
  from assms(2) have "bi_unique ?T'" unfolding bi_unique_def by simp
  moreover from assms(3) have "K'  Collect (Domainp ?T')" by blast
  moreover from assms(4) have "rel_set ?T' (K') xl" 
    unfolding rel_set_def by simp
  ultimately have "({(x, y). rel_set ?T' x y} `` K') = xl" 
    by (rule bi_unique_Union_r)
  thus ?thesis using K by simp
qed

context
  includes lifting_syntax
begin

text‹
The lemma text‹Domainp_applyI› was adopted from the lemma with the 
identical name in the theory text‹Types_To_Sets/Group_on_With.thy›.
›
lemma Domainp_applyI:
  includes lifting_syntax
  shows "(A ===> B) f g  A x y  Domainp B (f x)"
  by (auto simp: rel_fun_def)

lemma Domainp_fun:
  assumes "left_unique A" 
  shows 
    "Domainp (rel_fun A B) = 
      (λf. f ` (Collect (Domainp A))  (Collect (Domainp B)))"
proof-
  have 
    "pred_fun (Domainp A) (Domainp B) = 
      (λf. f ` (Collect (Domainp A))  (Collect (Domainp B)))"
    by (simp add: image_subset_iff)
  from Domainp_pred_fun_eq[OF ‹left_unique A, of B, unfolded this]
  show ?thesis .  
qed

lemma Bex_fun_transfer[transfer_rule]:
  assumes "bi_unique A" "right_total B"
  shows 
    "(((A ===> B) ===> (=)) ===> (=)) 
      (Bex (Collect (λf. f ` (Collect (Domainp A))  (Collect (Domainp B))))) 
      Ex"
proof-
  from assms(1) have "left_unique A" by (simp add: bi_unique_alt_def)
  note right_total_BA[transfer_rule] = 
    right_total_fun[
      OF conjunct2[OF bi_unique_alt_def[THEN iffD1, OF assms(1)]] assms(2)
      ]
  show ?thesis 
    unfolding Domainp_fun[OF ‹left_unique A, symmetric]
    by transfer_prover
qed

end

text‹\newpage›

end

Theory SML_Relations

(* Title: Examples/SML_Relativization/Foundations/SML_Relations.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about relations›
theory SML_Relations
  imports Main
begin



subsection‹Definitions and common properties›

context 
  notes [[inductive_internals]]
begin

inductive_set trancl_on :: "['a set, ('a × 'a) set]  ('a × 'a) set"
  (on _/ (_+) [1000, 1000] 999)
  for U :: "'a set" and r :: "('a × 'a) set" 
  where
    r_into_trancl[intro, Pure.intro]: 
      " a  U; b  U; (a, b)  r   (a, b)  on U r+"
  | trancl_into_trancl[Pure.intro]: 
      "
       a  U; b  U; c  U; (a, b)  on U r+; (b, c)  r   
        (a, c)  on U r+
      "

abbreviation tranclp_on (on _/ (_++) [1000, 1000] 1000) where
  "tranclp_on  trancl_onp"

declare trancl_on_def[nitpick_unfold del]

lemmas tranclp_on_def = trancl_onp_def

end

definition transp_on :: "['a set, ['a, 'a]  bool]  bool"
  where "transp_on U = (λr. (xU. yU. zU. r x y  r y z  r x z))"

definition acyclic_on :: "['a set, ('a × 'a) set]  bool"
  where "acyclic_on U = (λr. (xU. (x, x)  on U r+))"

lemma trancl_on_eq_tranclp_on:
  "on P (λx y. (x, y)  r)++ x y = ((x, y)  on (Collect P) r+)" 
  unfolding trancl_on_def tranclp_on_def Set.mem_Collect_eq by simp

lemma trancl_on_imp_U: "(x, y)  on U r+   (x, y)  U × U"
  by (auto dest: trancl_on.cases)

lemmas tranclp_on_imp_P = trancl_on_imp_U[to_pred, simplified]

lemma trancl_on_imp_trancl: "(x, y)  on U r+  (x, y)  r+"
  by (induction rule: trancl_on.induct) auto

lemmas tranclp_on_imp_tranclp = trancl_on_imp_trancl[to_pred]

lemma tranclp_eq_tranclp_on: "r++ = on (λx. True) r++"
  unfolding tranclp_def tranclp_on_def by simp

lemma trancl_eq_trancl_on: "r+ = on UNIV r+"
  unfolding trancl_def trancl_on_def by (simp add: tranclp_eq_tranclp_on)

lemma transp_on_empty[simp]: "transp_on {} r" unfolding transp_on_def by simp

lemma transp_eq_transp_on: "transp = transp_on UNIV"
  unfolding transp_def transp_on_def by simp

lemma acyclic_on_empty[simp]: "acyclic_on {} r" unfolding acyclic_on_def by simp

lemma acyclic_eq_acyclic_on: "acyclic = acyclic_on UNIV"
  unfolding acyclic_def acyclic_on_def 
  unfolding trancl_def tranclp_def trancl_on_def tranclp_on_def 
  by simp



subsection‹Transfer rules I: const‹lfp› transfer›


text‹
The following context contains code from \cite{immler_re_2019}.
›

context
  includes lifting_syntax 
begin

lemma Inf_transfer[transfer_rule]: 
  "(rel_set (A ===> (=)) ===> A ===> (=)) Inf Inf"
  unfolding Inf_fun_def by transfer_prover

lemma less_eq_pred_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" 
  shows 
    "((A ===> (=)) ===> (A ===> (=)) ===> (=)) 
      (λf g. xCollect(Domainp A). f x  g x) (≤)"
  unfolding le_fun_def by transfer_prover

lemma lfp_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  defines "R  (((A ===> (=)) ===> (A ===> (=))) ===> (A ===> (=)))"
  shows "R (λf. lfp (λu x. if Domainp A x then f u x else bot)) lfp"
proof -
  have "R (λf. Inf {u. xCollect (Domainp A). f u x  u x}) lfp"
    unfolding R_def lfp_def by transfer_prover
  thus ?thesis by (auto simp: le_fun_def lfp_def)
qed

lemma Inf2_transfer[transfer_rule]:
  "(rel_set (T ===> T ===> (=)) ===> T ===> T ===> (=)) Inf Inf"
  unfolding Inf_fun_def by transfer_prover

lemma less_eq2_pred_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total T" 
  shows 
    "((T ===> T ===> (=)) ===> (T ===> T ===> (=)) ===> (=)) 
      (λf g. xCollect(Domainp T). yCollect(Domainp T). f x y  g x y) (≤)"
  unfolding le_fun_def by transfer_prover

lemma lfp2_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  defines 
    "R  
      (((A ===> A ===> (=)) ===> (A ===> A ===> (=))) ===> (A ===> A ===> (=)))"
  shows 
    "R 
      (
        λf. lfp 
          (
            λu x y. 
              if Domainp A x 
              then if Domainp A y then (f u) x y else bot 
              else bot
          )
      ) 
      lfp"
proof -
  have 
    "R 
      (
        λf. 
          Inf 
            {
              u. 
                xCollect (Domainp A). yCollect (Domainp A). 
                  (f u) x y  u x y
            }
      ) 
      lfp"
    unfolding R_def lfp_def by transfer_prover 
  thus ?thesis by (auto simp: le_fun_def lfp_def)
qed

end



subsection‹Transfer rules II: application-specific rules›

context
  includes lifting_syntax
begin

lemma transp_rt_transfer[transfer_rule]:
  assumes[transfer_rule]: "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (=)) (transp_on (Collect (Domainp A))) transp"
  unfolding transp_def transp_on_def by transfer_prover

lemma tranclp_rt_bu_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=))) 
      (tranclp_on (Domainp A)) tranclp"
  unfolding tranclp_on_def tranclp_def 
  apply transfer_prover_start
  apply transfer_step+
proof 
  fix r
  have 
    "(
      λp x y.
        (a b. x = a  y = b  Domainp A a  Domainp A b  r a b)  
        (
          a b c. 
            x = a  y = c  
            Domainp A a  Domainp A b  Domainp A c  
            p a b  r b c
        ) 
    ) = 
      (
        λp x y.
          if Domainp A x
          then if Domainp A y
            then 
              (
                aCollect (Domainp A). bCollect (Domainp A). 
                  x = a  y = b  r a b) 
                  (
                    aCollect (Domainp A). 
                    bCollect (Domainp A). 
                    cCollect (Domainp A). 
                      x = a  y = c  p a b  r b c
                  )
           else bot
         else bot
      )"
    (is "?lhs = ?rhs")
    by (intro ext) simp
  thus "lfp ?lhs = lfp ?rhs" by clarsimp
qed

lemma trancl_rt_bu_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(rel_set (rel_prod A A) ===> rel_set (rel_prod A A)) 
      (trancl_on (Collect (Domainp A))) trancl"
  unfolding trancl_on_def trancl_def
  apply transfer_prover_start
  apply transfer_step+
  by (auto simp: tranclp_on_imp_P[where U="Domainp A"])

lemma acyclic_rt_bu_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((rel_set (rel_prod A A)) ===> (=)) 
      (acyclic_on (Collect (Domainp A))) acyclic"
  unfolding acyclic_on_def acyclic_def by transfer_prover

end

text‹\newpage›

end

Theory SML_Simple_Orders

(* Title: Examples/SML_Relativization/Simple_Orders/SML_Simple_Orders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about orders›
theory SML_Simple_Orders
  imports 
    "../../Introduction"
    "../Foundations/SML_Relations"
    Complex_Main
begin



subsection‹Class class‹ord›


subsubsection‹Definitions and common properties›

locale ord_ow =
  fixes U :: "'ao set"
    and le :: "['ao, 'ao]  bool" (infix ow 50) 
    and ls :: "['ao, 'ao]  bool" (infix <ow 50)
begin

notation le ('(≤ow'))
  and le (infix ow 50) 
  and ls ('(<ow')) 
  and ls (infix <ow 50)

abbreviation (input) ge (infix ow 50) where "x ow y  y ow x"
abbreviation (input) gt (infix >ow 50) where "x >ow y  y <ow x"

notation ge ('(≥ow')) 
  and ge (infix ow 50) 
  and gt ('(>ow')) 
  and gt (infix >ow 50)

tts_register_sbts (≤ow) | U
proof-
  assume "Domainp AOA = (λx. x  U)" "bi_unique AOA" "right_total AOA" 
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts (<ow) | U
proof-
  assume "Domainp AOA = (λx. x  U)" "bi_unique AOA" "right_total AOA" 
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

end

locale ord_pair_ow = ord1: ord_ow U1 le1 ls1 + ord2: ord_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2
begin

notation le1 ('(≤ow.1'))
  and le1 (infix ow.1 50) 
  and ls1 ('(<ow.1')) 
  and ls1 (infix <ow.1 50)
  and le2 ('(≤ow.2'))
  and le2 (infix ow.2 50) 
  and ls2 ('(<ow.2')) 
  and ls2 (infix <ow.2 50)

notation ord1.ge ('(≥ow.1')) 
  and ord1.ge (infix ow.1 50) 
  and ord1.gt ('(>ow.1')) 
  and ord1.gt (infix >ow.1 50)
  and ord2.ge ('(≥ow.2')) 
  and ord2.ge (infix ow.2 50) 
  and ord2.gt ('(>ow.2')) 
  and ord2.gt (infix >ow.2 50)

end

ud ‹ord.lessThan› ((with _ : ({..<_})) [1000] 10)
ud lessThan' ‹lessThan› 
ud ‹ord.atMost› ((with _ : ({.._})) [1000] 10) 
ud atMost' ‹atMost› 
ud ‹ord.greaterThan› ((with _ : ({_<..})) [1000] 10) 
ud greaterThan' ‹greaterThan› 
ud ‹ord.atLeast› ((with _ : ({_..})) [1000] 10) 
ud atLeast' ‹atLeast› 
ud ‹ord.greaterThanLessThan› ((with _ : ({_<..<_})) [1000, 999, 1000] 10) 
ud greaterThanLessThan' ‹greaterThanLessThan› 
ud ‹ord.atLeastLessThan› ((with _ _ : ({_..<_})) [1000, 999, 1000, 1000] 10)
ud atLeastLessThan' ‹atLeastLessThan› 
ud ‹ord.greaterThanAtMost› ((with _ _ : ({_<.._})) [1000, 999, 1000, 999] 10) 
ud greaterThanAtMost' ‹greaterThanAtMost› 
ud ‹ord.atLeastAtMost› ((with _ : ({_.._})) [1000, 1000, 1000] 10) 
ud atLeastAtMost' ‹atLeastAtMost› 
ud ‹ord.min› ((with _ : «min» _ _) [1000, 1000, 999] 10)
ud min' ‹min› 
ud ‹ord.max› ((with _ : «max» _ _) [1000, 1000, 999] 10)
ud max' ‹max›

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "right_total A" 
  trp (?'a A)
  in lessThan_ow: lessThan.with_def 
    ((on _ with _ : ({..<_})) [1000, 1000, 1000] 10) 
    and atMost_ow: atMost.with_def 
      ((on _ with _ : ({.._})) [1000, 1000, 1000] 10) 
    and greaterThan_ow: greaterThan.with_def
      ((on _ with _: ({_<..})) [1000, 1000, 1000] 10) 
    and atLeast_ow: atLeast.with_def
      ((on _ with _ : ({_..})) [1000, 1000, 1000] 10) 

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "bi_unique A" "right_total A" 
  trp (?'a A)
  in greaterThanLessThan_ow: greaterThanLessThan.with_def 
      ((on _ with _ : ({_<..<_})) [1000, 1000, 1000, 1000] 10) 
    and atLeastLessThan_ow: atLeastLessThan.with_def 
      ((on _ with _ _ : ({_..<_})) [1000, 1000, 999, 1000, 1000] 10)
    and greaterThanAtMost_ow: greaterThanAtMost.with_def 
      ((on _ with _ _ : ({_<.._})) [1000, 1000, 999, 1000, 1000] 10) 
    and atLeastAtMost_ow: atLeastAtMost.with_def 
      ((on _ with _ : ({_.._})) [1000, 1000, 1000, 1000] 10)

ctr parametricity
  in min_ow: min.with_def
    and max_ow: max.with_def

context ord_ow
begin

abbreviation lessThan :: "'ao  'ao set" ("(1{..<ow_})") 
  where "{..<ow u}  on U with (<ow) : {..<u}"
abbreviation atMost :: "'ao  'ao set" ("(1{..ow_})") 
  where "{..ow u}  on U with (≤ow) : {..u}"
abbreviation greaterThan :: "'ao  'ao set" ("(1{_<ow..})")  
  where "{l<ow..}  on U with (<ow) : {l<..}"
abbreviation atLeast :: "'ao  'ao set" ("(1{_..ow})") 
  where "atLeast l  on U with (≤ow) : {l..}"
abbreviation greaterThanLessThan :: "'ao  'ao  'ao set" ("(1{_<ow..<ow_})")
  where "{l<ow..<owu}  on U with (<ow) : {l<..<u}"
abbreviation atLeastLessThan :: "'ao  'ao  'ao set" ("(1{_..<ow_})")
  where "{l..<ow u}  on U with (≤ow) (<ow) : {l<..u}"
abbreviation greaterThanAtMost :: "'ao  'ao  'ao set" ("(1{_<ow.._})")
  where "{l<ow..u}   on U with (≤ow) (<ow) : {l<..u}"
abbreviation atLeastAtMost :: "'ao  'ao  'ao set" ("(1{_..ow_})")
  where "{l..owu}  on U with (≤ow) : {l..u}"
abbreviation min :: "'ao  'ao  'ao" where "min  min.with (≤ow)"
abbreviation max :: "'ao  'ao  'ao" where "max  max.with (≤ow)"

end

context ord_pair_ow
begin

notation ord1.lessThan ("(1{..<ow.1_})") 
notation ord1.atMost ("(1{..ow.1_})") 
notation ord1.greaterThan ("(1{_<ow.1..})")  
notation ord1.atLeast ("(1{_..ow.1})") 
notation ord1.greaterThanLessThan ("(1{_<ow.1..<ow.1_})")
notation ord1.atLeastLessThan ("(1{_..<ow.1_})")
notation ord1.greaterThanAtMost ("(1{_<ow.1.._})")
notation ord1.atLeastAtMost ("(1{_..ow.1_})")

notation ord2.lessThan ("(1{..<ow.2_})") 
notation ord2.atMost ("(1{..ow.2_})") 
notation ord2.greaterThan ("(1{_<ow.2..})")  
notation ord2.atLeast ("(1{_..ow.2})") 
notation ord2.greaterThanLessThan ("(1{_<ow.2..<ow.2_})")
notation ord2.atLeastLessThan ("(1{_..<ow.2_})")
notation ord2.greaterThanAtMost ("(1{_<ow.2.._})")
notation ord2.atLeastAtMost ("(1{_..ow.2_})")

end



subsection‹Preorders›


subsubsection‹Definitions and common properties›

locale preorder_ow = ord_ow U le ls 
  for U :: "'ao set" and le ls +
  assumes less_le_not_le: 
    " x  U; y  U   x <ow y  x ow y  ¬ (y ow x)"
    and order_refl[iff]: "x  U  x ow x"
    and order_trans: " x  U; y  U; z  U; x ow y; y ow z   x ow z"

locale ord_preorder_ow = 
  ord1: ord_ow U1 le1 ls1 + ord2: preorder_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2
begin

sublocale ord_pair_ow .

end

locale preorder_pair_ow = 
  ord1: preorder_ow U1 le1 ls1 + ord2: preorder_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 and ls1 and U2 :: "'bo set" and le2 and ls2
begin

sublocale ord_preorder_ow ..

end

ud ‹preorder.bdd_above› ((with _ : «bdd'_above» _) [1000, 1000] 10)
ud bdd_above' ‹bdd_above› 
ud ‹preorder.bdd_below› ((with _ : «bdd'_below» _) [1000, 1000] 10)
ud bdd_below' ‹bdd_below› 

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "right_total A" 
  trp (?'a A)
  in bdd_above_ow: bdd_above.with_def
    ((on _ with _ : «bdd'_above» _) [1000, 1000, 1000] 10)
    and bdd_below_ow: bdd_below.with_def
    ((on _ with _ : «bdd'_below» _) [1000, 1000, 1000] 10)

context preorder_ow
begin

abbreviation bdd_above :: "'ao set  bool" 
  where "bdd_above  bdd_above_ow U (≤ow)"
abbreviation bdd_below :: "'ao set  bool" 
  where "bdd_below  bdd_below_ow U (≤ow)"

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma preorder_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=))  ===> (=)) 
      (preorder_ow (Collect (Domainp A))) class.preorder"
  unfolding preorder_ow_def class.preorder_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end


subsubsection‹Relativization›

context preorder_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting preorder_ow_axioms
  eliminating through auto
begin

tts_lemma less_irrefl:
  assumes "x  U"
  shows "¬ x <ow x"
  is preorder_class.less_irrefl.
    
tts_lemma bdd_below_Ioc:
  assumes "a  U" and "b  U"
  shows "bdd_below {a<ow..b}"
  is preorder_class.bdd_below_Ioc.
    
tts_lemma bdd_above_Ioc:
  assumes "a  U" and "b  U"
  shows "bdd_above {a<ow..b}"
    is preorder_class.bdd_above_Ioc.

tts_lemma bdd_above_Iic:
  assumes "b  U"
  shows "bdd_above {..owb}"
    is preorder_class.bdd_above_Iic.

tts_lemma bdd_above_Iio:
  assumes "b  U"
  shows "bdd_above {..<owb}"
    is preorder_class.bdd_above_Iio.

tts_lemma bdd_below_Ici:
  assumes "a  U"
  shows "bdd_below {a..ow}"
    is preorder_class.bdd_below_Ici.

tts_lemma bdd_below_Ioi:
  assumes "a  U"
  shows "bdd_below {a<ow..}"
    is preorder_class.bdd_below_Ioi.

tts_lemma bdd_above_Icc:
  assumes "a  U" and "b  U"
  shows "bdd_above {a..owb}"
    is preorder_class.bdd_above_Icc.

tts_lemma bdd_above_Ioo:
  assumes "a  U" and "b  U"
  shows "bdd_above {a<ow..<owb}"
    is preorder_class.bdd_above_Ioo.

tts_lemma bdd_below_Icc:
  assumes "a  U" and "b  U"
  shows "bdd_below {a..owb}"
    is preorder_class.bdd_below_Icc.

tts_lemma bdd_below_Ioo:
  assumes "a  U" and "b  U"
  shows "bdd_below {a<ow..<owb}"
    is preorder_class.bdd_below_Ioo.

tts_lemma bdd_above_Ico:
  assumes "a  U" and "b  U"
  shows "bdd_above (on U with (≤ow) (<ow) : {a..<b})"
    is preorder_class.bdd_above_Ico.

tts_lemma bdd_below_Ico:
  assumes "a  U" and "b  U"
  shows "bdd_below (on U with (≤ow) (<ow) : {a..<b})"
    is preorder_class.bdd_below_Ico.

tts_lemma Ioi_le_Ico:
  assumes "a  U"
  shows "{a<ow..}  {a..ow}"
    is preorder_class.Ioi_le_Ico.

tts_lemma eq_refl:
  assumes "y  U" and "x = y"
  shows "x ow y"
    is preorder_class.eq_refl.

tts_lemma less_imp_le:
  assumes "x  U" and "y  U" and "x <ow y"
  shows "x ow y"
    is preorder_class.less_imp_le.

tts_lemma less_not_sym:
  assumes "x  U" and "y  U" and "x <ow y"
  shows "¬ y <ow x"
    is preorder_class.less_not_sym.

tts_lemma less_imp_not_less:
  assumes "x  U" and "y  U" and "x <ow y"
  shows "(¬ y <ow x) = True"
    is preorder_class.less_imp_not_less.

tts_lemma less_asym':
  assumes "a  U" and "b  U" and "a <ow b" and "b <ow a"
  shows P
    is preorder_class.less_asym'.

tts_lemma less_imp_triv:
  assumes "x  U" and "y  U" and "x <ow y"
  shows "(y <ow x  P) = True"
    is preorder_class.less_imp_triv.

tts_lemma less_trans:
  assumes "x  U" and "y  U" and "z  U" and "x <ow y" and "y <ow z"
  shows "x <ow z"
    is preorder_class.less_trans.

tts_lemma less_le_trans:
  assumes "x  U" and "y  U" and "z  U" and "x <ow y" and "y ow z"
  shows "x <ow z"
    is preorder_class.less_le_trans.

tts_lemma le_less_trans:
  assumes "x  U" and "y  U" and "z  U" and "x ow y" and "y <ow z"
  shows "x <ow z"
    is preorder_class.le_less_trans.

tts_lemma bdd_aboveI:
  assumes "A  U" and "M  U" and "x. x  U; x  A  x ow M"
  shows "bdd_above A"
    is preorder_class.bdd_aboveI.

tts_lemma bdd_belowI:
  assumes "A  U" and "m  U" and "x. x  U; x  A  m ow x"
  shows "bdd_below A"
    is preorder_class.bdd_belowI.

tts_lemma less_asym:
  assumes "x  U" and "y  U" and "x <ow y" and "¬ P  y <ow x"
  shows P
    is preorder_class.less_asym.

tts_lemma transp_less: "transp_on U (<ow)"
  is preorder_class.transp_less.

tts_lemma transp_le: "transp_on U (≤ow)"
  is preorder_class.transp_le.

tts_lemma transp_gr: "transp_on U (λx y. y <ow x)"
  is preorder_class.transp_gr.

tts_lemma transp_ge: "transp_on U (λx y. y ow x)"
  is preorder_class.transp_ge.

tts_lemma bdd_above_Int1:
  assumes "A  U" and "B  U" and "bdd_above A"
  shows "bdd_above (A  B)"
    is preorder_class.bdd_above_Int1.

tts_lemma bdd_above_Int2:
  assumes "B  U" and "A  U" and "bdd_above B"
  shows "bdd_above (A  B)"
    is preorder_class.bdd_above_Int2.

tts_lemma bdd_below_Int1:
  assumes "A  U" and "B  U" and "bdd_below A"
  shows "bdd_below (A  B)"
    is preorder_class.bdd_below_Int1.

tts_lemma bdd_below_Int2:
  assumes "B  U" and "A  U" and "bdd_below B"
  shows "bdd_below (A  B)"
    is preorder_class.bdd_below_Int2.

tts_lemma bdd_above_mono:
  assumes "B  U" and "bdd_above B" and "A  B"
  shows "bdd_above A"
    is preorder_class.bdd_above_mono.

tts_lemma bdd_below_mono:
  assumes "B  U" and "bdd_below B" and "A  B"
  shows "bdd_below A"
    is preorder_class.bdd_below_mono.

tts_lemma atLeastAtMost_subseteq_atLeastLessThan_iff:
  assumes "a  U"
    and "b  U"
    and "c  U"
    and "d  U"
  shows "({a..owb}  (on U with (≤ow) (<ow) : {c..<d})) = 
    (a ow b  b <ow d  c ow a)"
    is preorder_class.atLeastAtMost_subseteq_atLeastLessThan_iff.

tts_lemma atMost_subset_iff:
  assumes "x  U" and "y  U"
  shows "({..owx}  {..owy}) = (x ow y)"
    is Set_Interval.atMost_subset_iff.

tts_lemma single_Diff_lessThan:
  assumes "k  U"
  shows "{k} - {..<owk} = {k}"
  is Set_Interval.single_Diff_lessThan.

tts_lemma atLeast_subset_iff:
  assumes "x  U" and "y  U"
  shows "({x..ow}  {y..ow}) = (y ow x)"
    is Set_Interval.atLeast_subset_iff.

tts_lemma atLeastatMost_psubset_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows 
    "({a..owb}  {c..owd}) = 
      (c ow d  (¬ a ow b  c ow a  b ow d  (c <ow a  b <ow d)))"
    is preorder_class.atLeastatMost_psubset_iff.

tts_lemma not_empty_eq_Iic_eq_empty:
  assumes "h  U"
  shows "{}  {..owh}"
    is preorder_class.not_empty_eq_Iic_eq_empty.
    
tts_lemma atLeastatMost_subset_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a..owb}  {c..owd}) = (¬ a ow b  b ow d  c ow a)"
    is preorder_class.atLeastatMost_subset_iff.

tts_lemma Icc_subset_Ici_iff:
  assumes "l  U" and "h  U" and "l'  U"
  shows "({l..owh}  {l'..ow}) = (¬ l ow h  l' ow l)"
    is preorder_class.Icc_subset_Ici_iff.
    
tts_lemma Icc_subset_Iic_iff:
  assumes "l  U" and "h  U" and "h'  U"
  shows "({l..owh}  {..owh'}) = (¬ l ow h  h ow h')"
    is preorder_class.Icc_subset_Iic_iff.

tts_lemma not_empty_eq_Ici_eq_empty:
  assumes "l  U"
  shows "{}  {l..ow}"
  is preorder_class.not_empty_eq_Ici_eq_empty.
    
tts_lemma not_Ici_eq_empty:
  assumes "l  U"
  shows "{l..ow}  {}"
is preorder_class.not_Ici_eq_empty.
    
tts_lemma not_Iic_eq_empty:
  assumes "h  U"
  shows "{..owh}  {}"
    is preorder_class.not_Iic_eq_empty.

tts_lemma atLeastatMost_empty_iff2:
  assumes "a  U" and "b  U"
  shows "({} = {a..owb}) = (¬ a ow b)"
    is preorder_class.atLeastatMost_empty_iff2.
    
tts_lemma atLeastLessThan_empty_iff2:
  assumes "a  U" and "b  U"
  shows "({} = (on U with (≤ow) (<ow) : {a..<b})) = (¬ a <ow b)"
    is preorder_class.atLeastLessThan_empty_iff2.
    
tts_lemma greaterThanAtMost_empty_iff2:
  assumes "k  U" and "l  U"
  shows "({} = {k<ow..l}) = (¬ k <ow l)"
    is preorder_class.greaterThanAtMost_empty_iff2.
    
tts_lemma atLeastatMost_empty_iff:
  assumes "a  U" and "b  U"
  shows "({a..owb} = {}) = (¬ a ow b)"
    is preorder_class.atLeastatMost_empty_iff.
    
tts_lemma atLeastLessThan_empty_iff:
  assumes "a  U" and "b  U"
  shows "((on U with (≤ow) (<ow) : {a..<b}) = {}) = (¬ a <ow b)"
    is preorder_class.atLeastLessThan_empty_iff.
    
tts_lemma greaterThanAtMost_empty_iff:
  assumes "k  U" and "l  U"
  shows "({k<ow..l} = {}) = (¬ k <ow l)"
    is preorder_class.greaterThanAtMost_empty_iff.

end


tts_context
  tts: (?'a to U)
  substituting preorder_ow_axioms
begin

tts_lemma bdd_above_empty:
  assumes "U  {}"
  shows "bdd_above {}"
    is preorder_class.bdd_above_empty.
    
tts_lemma bdd_below_empty:
  assumes "U  {}"
  shows "bdd_below {}"
    is preorder_class.bdd_below_empty.
    
end

tts_context
  tts: (?'a to U) and (?'b to U2::'a set›)
  rewriting ctr_simps
  substituting preorder_ow_axioms
  eliminating through (auto intro: bdd_above_empty bdd_below_empty)
begin

tts_lemma bdd_belowI2:
  assumes "A  U2"
    and "m  U"
    and "xU2. f x  U"
    and "x. x  A  m ow f x"
  shows "bdd_below (f ` A)"
    given preorder_class.bdd_belowI2
  by blast

tts_lemma bdd_aboveI2:
  assumes "A  U2"
    and "xU2. f x  U"
    and "M  U"
    and "x. x  A  f x ow M"
  shows "bdd_above (f ` A)"
    given preorder_class.bdd_aboveI2
  by blast
    
end

end



subsection‹Partial orders›


subsubsection‹Definitions and common properties›

locale ordering_ow =
  fixes U :: "'ao set"
    and le :: "'ao  'ao  bool" (infix "ow" 50)
    and ls :: "'ao  'ao  bool" (infix "<ow" 50)
  assumes strict_iff_order: " a  U; b  U   a <ow b  a ow b  a  b"
    and refl: "a  U  a ow a"
    and antisym: " a  U; b  U; a ow b; b ow a   a = b"
    and trans: " a  U; b  U; c  U; a ow b; b ow c   a ow c"
begin

notation le (infix "ow" 50)
  and ls (infix "<ow" 50)

end

locale order_ow = preorder_ow U le ls for U :: "'ao set" and le ls +
  assumes antisym: " x  U; y  U; x ow y; y ow x   x = y" 
begin

sublocale 
  order: ordering_ow U (≤ow) (<ow) + 
  dual_order: ordering_ow U (≥ow) (>ow)
  apply unfold_locales
  subgoal by (force simp: less_le_not_le antisym)
  subgoal by simp 
  subgoal by (simp add: antisym)
  subgoal by (metis order_trans)
  subgoal by (force simp: less_le_not_le antisym)
  subgoal by (simp add: antisym)
  subgoal by (metis order_trans)
  done

no_notation le (infix "ow" 50)
  and ls (infix "<ow" 50)

end

locale ord_order_ow = ord1: ord_ow U1 le1 ls1 + ord2: order_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2

sublocale ord_order_ow  ord_preorder_ow ..

locale preorder_order_ow =
  ord1: preorder_ow U1 le1 ls1 + ord2: order_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2

sublocale preorder_order_ow  preorder_pair_ow ..

locale order_pair_ow = ord1: order_ow U1 le1 ls1 + ord2: order_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2

sublocale order_pair_ow  preorder_order_ow ..

ud ‹order.mono› ((with _ _ : «mono» _) [1000, 999, 1000] 10)
ud mono' ‹mono› 
ud ‹order.strict_mono› ((with _ _ : «strict'_mono» _) [1000, 999, 1000] 10)
ud strict_mono' ‹strict_mono› 
ud ‹order.antimono› ((with _ _ : «strict'_mono» _) [1000, 999, 1000] 10)
ud antimono' ‹antimono› 
ud ‹monoseq› ((with _ : «monoseq» _) [1000, 1000] 10)

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: 
    "Domainp (B::'c'dbool) = (λx. x  U2)"
    and [transfer_rule]: "right_total B" 
  trp (?'b A::'a'bbool›) and (?'a B)
  in mono_ow: mono.with_def 
    ((on _ with _ _ : «mono» _) [1000, 1000, 999, 1000] 10)
    and strict_mono_ow: strict_mono.with_def 
      ((on _ with _ _ : «strict'_mono» _) [1000, 1000, 999, 1000] 10)
    and antimono_ow: antimono.with_def
      ((on _ with _ _ : «antimono» _) [1000, 1000, 999, 1000] 10)
    and monoseq_ow: monoseq.with_def


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma ordering_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      (ordering_ow (Collect (Domainp A))) ordering"
  unfolding ordering_ow_def ordering_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_Collect[symmetric]
  by (intro ext HOL.arg_cong2[where f="(∧)"]) auto

lemma order_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      (order_ow (Collect (Domainp A))) class.order"
  unfolding 
    order_ow_def class.order_def order_ow_axioms_def class.order_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end


subsubsection‹Relativization›

context ordering_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ordering_ow_axioms
  eliminating through simp
begin

tts_lemma irrefl:
  assumes "a  U"
  shows "¬ a <ow a"
    is ordering.irrefl.
    
tts_lemma strict_implies_order:
  assumes "a  U" and "b  U" and "a <ow b"
  shows "a ow b"
  is ordering.strict_implies_order.
    
tts_lemma strict_implies_not_eq:
  assumes "a  U" and "b  U" and "a <ow b"
  shows "a  b"
    is ordering.strict_implies_not_eq.
    
tts_lemma order_iff_strict:
  assumes "a  U" and "b  U"
  shows "(a ow b) = (a <ow b  a = b)"
    is ordering.order_iff_strict.
    
tts_lemma asym:
  assumes "a  U" and "b  U" and "a <ow b" and "b <ow a"
  shows False
    is ordering.asym.
    
tts_lemma strict_trans:
  assumes "a  U" and "b  U" and "c  U" and "a <ow b" and "b <ow c"
  shows "a <ow c"
    is ordering.strict_trans.
    
tts_lemma strict_trans2:
  assumes "a  U" and "b  U" and "c  U" and "a <ow b" and "b ow c"
  shows "a <ow c"
    is ordering.strict_trans2.
    
tts_lemma strict_trans1:
  assumes "a  U" and "b  U" and "c  U" and "a ow b" and "b <ow c"
  shows "a <ow c"
    is ordering.strict_trans1.
    
tts_lemma not_eq_order_implies_strict:
  assumes "a  U" and "b  U" and "a  b" and "a ow b"
  shows "a <ow b"
    is ordering.not_eq_order_implies_strict.

end

end

context order_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through clarsimp
begin

tts_lemma atLeastAtMost_singleton:
  assumes "a  U"
  shows "{a..owa} = {a}"
  is order_class.atLeastAtMost_singleton.
    
tts_lemma less_imp_neq:
  assumes "y  U" and "x <ow y"
  shows "x  y"
    is order_class.less_imp_neq.
    
tts_lemma atLeastatMost_empty:
  assumes "b  U" and "a  U" and "b <ow a"
  shows "{a..owb} = {}"
    is order_class.atLeastatMost_empty.
    
tts_lemma less_imp_not_eq:
  assumes "y  U" and "x <ow y"
  shows "(x = y) = False"
    is order_class.less_imp_not_eq.
    
tts_lemma less_imp_not_eq2:
  assumes "y  U" and "x <ow y"
  shows "(y = x) = False"
    is order_class.less_imp_not_eq2.
    
tts_lemma atLeastLessThan_empty:
  assumes "b  U" and "a  U" and "b ow a"
  shows "(on U with (≤ow) (<ow) : {a..<b}) = {}"
    is order_class.atLeastLessThan_empty.
    
tts_lemma greaterThanAtMost_empty:
  assumes "l  U" and "k  U" and "l ow k"
  shows "{k<ow..l} = {}"
    is order_class.greaterThanAtMost_empty.

tts_lemma antisym_conv1:
  assumes "x  U" and "y  U" and "¬ x <ow y"
  shows "(x ow y) = (x = y)"
    is order_class.antisym_conv1.

tts_lemma antisym_conv2:
  assumes "x  U" and "y  U" and "x ow y"
  shows "(¬ x <ow y) = (x = y)"
    is order_class.antisym_conv2.
    
tts_lemma greaterThanLessThan_empty:
  assumes "l  U" and "k  U" and "l ow k"
  shows "{k<ow..<owl} = {}"
    is order_class.greaterThanLessThan_empty.
    
tts_lemma atLeastLessThan_eq_atLeastAtMost_diff:
  assumes "a  U" and "b  U"
  shows "(on U with (≤ow) (<ow) : {a..<b}) = {a..owb} - {b}"
    is order_class.atLeastLessThan_eq_atLeastAtMost_diff.
    
tts_lemma greaterThanAtMost_eq_atLeastAtMost_diff:
  assumes "a  U" and "b  U"
  shows "{a<ow..b} = {a..owb} - {a}"
    is order_class.greaterThanAtMost_eq_atLeastAtMost_diff.

tts_lemma less_separate:
  assumes "x  U" and "y  U" and "x <ow y"
  shows 
    "x'U. y'U. x  {..<owx'}  y  {y'<ow..}  {..<owx'}  {y'<ow..} = {}"
    is order_class.less_separate.

tts_lemma eq_iff:
  assumes "x  U" and "y  U"
  shows "(x = y) = (x ow y  y ow x)"
    is order_class.eq_iff.

tts_lemma order_iff_strict:
  assumes "a  U" and "b  U"
  shows "(a ow b) = (a <ow b  a = b)"
    is order_class.order.order_iff_strict.
    
tts_lemma le_less:
  assumes "x  U" and "y  U"
  shows "(x ow y) = (x <ow y  x = y)"
    is order_class.le_less.

tts_lemma asym:
  assumes "a  U" and "b  U" and "a <ow b" and "b <ow a"
  shows False
    is order_class.order.asym.
    
tts_lemma strict_iff_order:
  assumes "a  U" and "b  U"
  shows "(a <ow b) = (a ow b  a  b)"
    is order_class.order.strict_iff_order.
    
tts_lemma less_le:
  assumes "x  U" and "y  U"
  shows "(x <ow y) = (x ow y  x  y)"
    is order_class.less_le.

tts_lemma atLeastAtMost_singleton':
  assumes "b  U" and "a = b"
  shows "{a..owb} = {a}"
    is order_class.atLeastAtMost_singleton'.
    
tts_lemma le_imp_less_or_eq:
  assumes "x  U" and "y  U" and "x ow y"
  shows "x <ow y  x = y"
    is order_class.le_imp_less_or_eq.
  
tts_lemma antisym_conv:
  assumes "y  U" and "x  U" and "y ow x"
  shows "(x ow y) = (x = y)"
    is order_class.antisym_conv.

tts_lemma strict_trans:
  assumes "a  U" and "b  U" and "c  U" and "a <ow b" and "b <ow c"
  shows "a <ow c"
    is order_class.order.strict_trans.

tts_lemma strict_trans2:
  assumes "a  U" and "b  U" and "c  U" and "a <ow b" and "b ow c"
  shows "a <ow c"
    is order_class.order.strict_trans2.

tts_lemma strict_trans1:
  assumes "a  U" and "b  U" and "c  U" and "a ow b" and "b <ow c"
  shows "a <ow c"
    is order_class.order.strict_trans1.
    
tts_lemma le_neq_trans:
  assumes "a  U" and "b  U" and "a ow b" and "a  b"
  shows "a <ow b"
    is order_class.le_neq_trans.

tts_lemma neq_le_trans:
  assumes "a  U" and "b  U" and "a  b" and "a ow b"
  shows "a <ow b"
    is order_class.neq_le_trans.
    
tts_lemma Iio_Int_singleton:
  assumes "k  U" and "x  U"
  shows "{..<owk}  {x} = (if x <ow k then {x} else {})"
    is order_class.Iio_Int_singleton.
    
tts_lemma atLeastAtMost_singleton_iff:
  assumes "a  U" and "b  U" and "c  U"
  shows "({a..owb} = {c}) = (a = b  b = c)"
    is order_class.atLeastAtMost_singleton_iff.
    
tts_lemma Icc_eq_Icc:
  assumes "l  U" and "h  U" and "l'  U" and "h'  U"
  shows "({l..owh} = {l'..owh'}) = (h = h'  l = l'  ¬ l' ow h'  ¬ l ow h)"
    is order_class.Icc_eq_Icc.
    
tts_lemma lift_Suc_mono_less_iff:
  assumes "range f  U" and "n. f n <ow f (Suc n)"
  shows "(f n <ow f m) = (n < m)"
    is order_class.lift_Suc_mono_less_iff.

tts_lemma lift_Suc_mono_less:
  assumes "range f  U" and "n. f n <ow f (Suc n)" and "n < n'"
  shows "f n <ow f n'"
    is order_class.lift_Suc_mono_less.
  
tts_lemma lift_Suc_mono_le:
  assumes "range f  U" and "n. f n ow f (Suc n)" and "n  n'"
  shows "f n ow f n'"
    is order_class.lift_Suc_mono_le.
    
tts_lemma lift_Suc_antimono_le:
  assumes "range f  U" and "n. f (Suc n) ow f n" and "n  n'"
  shows "f n' ow f n"
    is order_class.lift_Suc_antimono_le.

tts_lemma ivl_disj_int_two:
  assumes "l  U" and "m  U" and "u  U"
  shows 
    "{l<ow..<owm}  (on U with (≤ow) (<ow) : {m..<u}) = {}"
    "{l<ow..m}  {m<ow..<owu} = {}"
    "(on U with (≤ow) (<ow) : {l..<m})  (on U with (≤ow) (<ow) : {m..<u}) = {}"
    "{l..owm}  {m<ow..<owu} = {}"
    "{l<ow..<owm}  {m..owu} = {}"
    "{l<ow..m}  {m<ow..u} = {}"
    "(on U with (≤ow) (<ow) : {l..<m})  {m..owu} = {}"
    "{l..owm}  {m<ow..u} = {}"
    is Set_Interval.ivl_disj_int_two.
  
tts_lemma ivl_disj_int_one:
  assumes "l  U" and "u  U"
  shows 
    "{..owl}  {l<ow..<owu} = {}"
    "{..<owl}  (on U with (≤ow) (<ow) : {l..<u}) = {}"
    "{..owl}  {l<ow..u} = {}"
    "{..<owl}  {l..owu} = {}"
    "{l<ow..u}  {u<ow..} = {}"
    "{l<ow..<owu}  {u..ow} = {}"
    "{l..owu}  {u<ow..} = {}"
    "(on U with (≤ow) (<ow) : {l..<u})  {u..ow} = {}"
    is Set_Interval.ivl_disj_int_one.

tts_lemma min_absorb2:
  assumes "y  U" and "x  U" and "y ow x"
  shows "local.min x y = y"
    is Orderings.min_absorb2.
    
tts_lemma max_absorb1:
  assumes "y  U" and "x  U" and "y ow x"
  shows "local.max x y = x"
    is Orderings.max_absorb1.

tts_lemma finite_mono_remains_stable_implies_strict_prefix:
  assumes "range f  U"
    and "finite (range f)"
    and "on UNIV with (≤ow) (≤) : «mono» f"
    and "n. f n = f (Suc n)  f (Suc n) = f (Suc (Suc n))"
  shows "N. (nN. f N = f n)  (nN. mN. m < n  f m <ow f n)"
    is Hilbert_Choice.finite_mono_remains_stable_implies_strict_prefix.
    
tts_lemma incseq_imp_monoseq:
  assumes "range X  U" and "on UNIV with (≤ow) (≤) : «mono» X"
  shows "with (≤ow) : «monoseq» X"
    is Topological_Spaces.incseq_imp_monoseq.
    
tts_lemma decseq_imp_monoseq:
  assumes "range X  U" and "on UNIV with (≤ow) (≤) : «antimono» X"
  shows "with (≤ow) : «monoseq» X"
    is Topological_Spaces.decseq_imp_monoseq.
    
tts_lemma irrefl:
  assumes "a  U"
  shows "¬ a <ow a"
    is order_class.order.irrefl.
    
tts_lemma incseq_Suc_iff:
  assumes "range f  U"
  shows "(on UNIV with (≤ow) (≤) : «mono» f) = (x. f x ow f (Suc x))"
    is Topological_Spaces.incseq_Suc_iff.
    
tts_lemma decseq_Suc_iff:
  assumes "range f  U"
  shows "(on UNIV with (≤ow) (≤) : «antimono» f) = (x. f (Suc x) ow f x)"
    is Topological_Spaces.decseq_Suc_iff.

tts_lemma incseq_const:
  assumes "k  U"
  shows "on (UNIV::nat set) with (≤ow) (≤) : «mono» (λx. k)"
    is Topological_Spaces.incseq_const.

tts_lemma decseq_const:
  assumes "k  U"
  shows "on (UNIV::nat set) with (≤ow) (≤) : «antimono» (λx. k)"
    is Topological_Spaces.decseq_const.

tts_lemma atMost_Int_atLeast:
  assumes "n  U"
  shows "{..own}  {n..ow} = {n}"
    is Set_Interval.atMost_Int_atLeast.

tts_lemma monoseq_iff:
  assumes "range X  U"
  shows 
    "(with (≤ow) : «monoseq» X) = 
      (
        (on UNIV with (≤ow) (≤) : «mono» X)  
        (on UNIV with (≤ow) (≤) : «antimono» X)
      )"
    is Topological_Spaces.monoseq_iff.

tts_lemma monoseq_Suc:
  assumes "range X  U"
  shows 
    "(with (≤ow) : «monoseq» X) = 
      ((x. X x ow X (Suc x))  (x. X (Suc x) ow X x))"
    is Topological_Spaces.monoseq_Suc.

tts_lemma incseq_SucI:
  assumes "range X  U" and "n. X n ow X (Suc n)"
  shows "on UNIV with (≤ow) (≤) : «mono» X"
    is Topological_Spaces.incseq_SucI.

tts_lemma incseq_SucD:
  assumes "range A  U" and "on UNIV with (≤ow) (≤) : «mono» A"
  shows "A i ow A (Suc i)"
    is Topological_Spaces.incseq_SucD.

tts_lemma decseq_SucI:
  assumes "range X  U" and "n. X (Suc n) ow X n"
  shows "on UNIV with (≤ow) (≤) : «antimono» X"
    is Topological_Spaces.decseq_SucI.

tts_lemma decseq_SucD:
  assumes "range A  U" and "on UNIV with (≤ow) (≤) : «antimono» A"
  shows "A (Suc i) ow A i"
    is Topological_Spaces.decseq_SucD.

tts_lemma mono_SucI2:
  assumes "range X  U" and "x. X (Suc x) ow X x"
  shows "with (≤ow) : «monoseq» X"
    is Topological_Spaces.mono_SucI2.

tts_lemma mono_SucI1:
  assumes "range X  U" and "x. X x ow X (Suc x)"
  shows "with (≤ow) : «monoseq» X"
    is Topological_Spaces.mono_SucI1.

tts_lemma incseqD:
  assumes "range f  U" 
    and "on UNIV with (≤ow) (≤) : «mono» f" 
    and "(i::nat)  j"
  shows "f i ow f j"
    is Topological_Spaces.incseqD.

tts_lemma decseqD:
  assumes "range f  U"
    and "on UNIV with (≤ow) (≤) : «antimono» f"
    and "(i::nat)  j"
  shows "f j ow f i"
    is Topological_Spaces.decseqD.

tts_lemma monoI2:
  assumes "range X  U" and "x y. x  y  X y ow X x"
  shows "with (≤ow) : «monoseq» X"
    is Topological_Spaces.monoI2.

tts_lemma monoI1:
  assumes "range X  U" and "x y. x  y  X x ow X y"
  shows "with (≤ow) : «monoseq» X"
    is Topological_Spaces.monoI1.

tts_lemma antimono_iff_le_Suc:
  assumes "range f  U"
  shows "(on UNIV with (≤ow) (≤) : «antimono» f) = (x. f (Suc x) ow f x)"
    is Nat.antimono_iff_le_Suc.

tts_lemma mono_iff_le_Suc:
  assumes "range f  U"
  shows "(on UNIV with (≤ow) (≤) : «mono» f) = (x. f x ow f (Suc x))"
    is Nat.mono_iff_le_Suc.

tts_lemma funpow_mono2:
  assumes "xU. f x  U"
    and "x  U"
    and "y  U"
    and "on U with (≤ow) (≤ow) : «mono» f"
    and "i  j"
    and "x ow y"
    and "x ow f x"
  shows "(f ^^ i) x ow (f ^^ j) y"
    is Nat.funpow_mono2.

tts_lemma funpow_mono:
  assumes "xU. f x  U"
    and "A  U"
    and "B  U"
    and "on U with (≤ow) (≤ow) : «mono» f"
    and "A ow B"
  shows "(f ^^ n) A ow (f ^^ n) B"
    is Nat.funpow_mono.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through clarsimp
begin

tts_lemma ex_min_if_finite:
  assumes "S  U"
    and "finite S"
    and "S  {}"
  shows "xS. ¬ (yS. y <ow x)"
    is Lattices_Big.ex_min_if_finite.
    
end

tts_context
  tts: (?'a to U)
  sbterms: ((≤)::['a::order, 'a::order]  bool› to (≤ow)) 
    and ((<)::['a::order, 'a::order]  bool› to (<ow))
  substituting order_ow_axioms
  eliminating through clarsimp
begin

tts_lemma xt1:
  shows 
    "a = b; c <ow b  c <ow a"
    "b <ow a; b = c  c <ow a"
    "a = b; c ow b  c ow a"
    "b ow a; b = c  c ow a"
    "y  U; x  U; y ow x; x ow y  x = y"
    "y  U; x  U; z  U; y ow x; z ow y  z ow x"
    "y  U; x  U; z  U; y <ow x; z ow y  z <ow x"
    "y  U; x  U; z  U; y ow x; z <ow y  z <ow x"
    "b  U; a  U; b <ow a; a <ow b  P"
    "y  U; x  U; z  U; y <ow x; z <ow y  z <ow x"
    "b  U; a  U; b ow a; a  b  b <ow a"
    "a  U; b  U; a  b; b ow a  b <ow a"
    "
      b  U;
      c  U;
      a = f b;
      c <ow b;
      x y. x  U; y  U; y <ow x  f y <ow f x
       f c <ow a"
    "
      b  U;
      a  U;
      b <ow a;
      f b = c;
      x y. x  U; y  U; y <ow x  f y <ow f x
        c <ow f a"
    "
      b  U;
      c  U;
      a = f b;
      c ow b;
      x y. x  U; y  U; y ow x  f y ow f x
       f c ow a"
    "
      b  U; 
      a  U; 
      b ow a; 
      f b = c; 
      x y. x  U; y  U; y ow x  f y ow f x
       c ow f a"
    is Orderings.xt1.

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through (simp add: mono_ow_def)
begin

tts_lemma coinduct3_mono_lemma:
  assumes "xU. f x  U2"
    and "X  U2"
    and "B  U2"
    and "on U with (⊆) (≤ow) : «mono» f"
  shows "on U with (⊆) (≤ow) : «mono» (λx. f x  (X  B))"
    is Inductive.coinduct3_mono_lemma.

end

end

context ord_order_ow 
begin

tts_context
  tts: (?'a to U2) and (?'b to U1)
  sbterms: ((≤)::[?'a::order, ?'a::order]  bool› to (≤ow.2)) 
    and ((<)::[?'a::order, ?'a::order]  bool› to (<ow.2)) 
    and ((≤)::[?'b::ord, ?'b::ord]  bool› to (≤ow.1)) 
    and ((<)::[?'b::ord, ?'b::ord]  bool› to (<ow.1)) 
  rewriting ctr_simps
  substituting ord2.order_ow_axioms
  eliminating through clarsimp
begin

tts_lemma xt2:
  assumes "xU1. f x  U2"
    and "b  U1"
    and "a  U2"
    and "c  U1"
    and "f b ow.2 a"
    and "c ow.1 b"
    and "x y. x  U1; y  U1; y ow.1 x  f y ow.2 f x"
  shows "f c ow.2 a"
  is Orderings.xt2.
    
tts_lemma xt6:
  assumes "xU1. f x  U2"
    and "b  U1"
    and "a  U2"
    and "c  U1"
    and "f b ow.2 a"
    and "c <ow.1 b"
    and "x y. x  U1; y  U1; y <ow.1 x  f y <ow.2 f x"
  shows "f c <ow.2 a"
    is Orderings.xt6.

end

end

context order_pair_ow 
begin

tts_context
  tts: (?'a to U1) and (?'b to U2)
  rewriting ctr_simps
  substituting ord1.order_ow_axioms and ord2.order_ow_axioms
  eliminating through
    (
      unfold
        strict_mono_ow_def
        mono_ow_def
        antimono_ow_def
        bdd_above_ow_def
        bdd_below_ow_def,
      clarsimp
    )
begin

tts_lemma antimonoD:
  assumes "x  U1"
    and "y  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «antimono» f"
    and "x ow.1 y"
  shows "f y ow.2 f x"
    is Orderings.antimonoD.
    
tts_lemma monoD:
  assumes "x  U1"
    and "y  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    and "x ow.1 y"
  shows "f x ow.2 f y"
    is Orderings.monoD.
    
tts_lemma strict_monoD:
  assumes "x  U1"
    and "y  U1"
    and "on U1 with (<ow.2) (<ow.1) : «strict_mono» f"
    and "x <ow.1 y"
  shows "f x <ow.2 f y"
    is Orderings.strict_monoD.
    
tts_lemma strict_monoI:
  assumes "x y. x  U1; y  U1; x <ow.1 y  f x <ow.2 f y"
  shows "on U1 with (<ow.2) (<ow.1) : «strict_mono» f"
    is Orderings.strict_monoI.
    
tts_lemma antimonoI:
  assumes "x y. x  U1; y  U1; x ow.1 y  f y ow.2 f x"
  shows "on U1 with (≤ow.2) (≤ow.1) : «antimono» f"
    is Orderings.antimonoI.
    
tts_lemma monoI:
  assumes "x y. x  U1; y  U1; x ow.1 y  f x ow.2 f y"
  shows "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    is Orderings.monoI.
    
tts_lemma antimonoE:
  assumes "x  U1"
    and "y  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «antimono» f"
    and "x ow.1 y"
    and "f y ow.2 f x  thesis"
  shows thesis
    is Orderings.antimonoE.

tts_lemma monoE:
  assumes "x  U1"
    and "y  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    and "x ow.1 y"
    and "f x ow.2 f y  thesis"
  shows thesis
    is Orderings.monoE.

tts_lemma strict_mono_mono:
  assumes "xU1. f x  U2"
    and "on U1 with (<ow.2) (<ow.1) : «strict_mono» f"
  shows "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    is Orderings.strict_mono_mono.
    
tts_lemma bdd_below_image_antimono:
  assumes "xU1. f x  U2"
    and "A  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «antimono» f"
    and "ord1.bdd_above A"
  shows "ord2.bdd_below (f ` A)"
    is Conditionally_Complete_Lattices.bdd_below_image_antimono.

tts_lemma bdd_above_image_antimono:
  assumes "xU1. f x  U2"
    and "A  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «antimono» f"
    and "ord1.bdd_below A"
  shows "ord2.bdd_above (f ` A)"
    is Conditionally_Complete_Lattices.bdd_above_image_antimono.

tts_lemma bdd_below_image_mono:
  assumes "xU1. f x  U2"
    and "A  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    and "ord1.bdd_below A"
  shows "ord2.bdd_below (f ` A)"
    is Conditionally_Complete_Lattices.bdd_below_image_mono.
    
tts_lemma bdd_above_image_mono:
  assumes "xU1. f x  U2"
    and "A  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    and "ord1.bdd_above A"
  shows "ord2.bdd_above (f ` A)"
    is Conditionally_Complete_Lattices.bdd_above_image_mono.

tts_lemma strict_mono_leD:
  assumes "xU1. r x  U2"
    and "m  U1"
    and "n  U1"
    and "on U1 with (<ow.2) (<ow.1) : «strict_mono» r"
    and "m ow.1 n"
  shows "r m ow.2 r n"
    is Topological_Spaces.strict_mono_leD.

tts_lemma mono_image_least:
  assumes "xU1. f x  U2"
    and "m  U1"
    and "n  U1"
    and "m'  U2"
    and "n'  U2"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
    and "f ` (on U1 with (≤ow.1) (<ow.1) : {m..<n}) = 
      (on U2 with (≤ow.2) (<ow.2) : {m'..<n'})"
    and "m <ow.1 n"
  shows "f m = m'"
    is Set_Interval.mono_image_least.

end

tts_context
  tts: (?'a to U1) and (?'b to U2)
  sbterms: ((≤)::[?'a::order, ?'a::order]  bool› to (≤ow.1)) 
    and ((<)::[?'a::order, ?'a::order]  bool› to (<ow.1)) 
    and ((≤)::[?'b::order, ?'b::order]  bool› to (≤ow.2)) 
    and ((<)::[?'b::order, ?'b::order]  bool› to (<ow.2))
  rewriting ctr_simps
  substituting ord1.order_ow_axioms and ord2.order_ow_axioms
  eliminating through clarsimp
begin

tts_lemma xt3:
  assumes "b  U1"
    and "a  U1"
    and "c  U2"
    and "xU1. f x  U2"
    and "b ow.1 a"
    and "c ow.2 f b"
    and "x y. x  U1; y  U1; y ow.1 x  f y ow.2 f x"
  shows "c ow.2 f a"
    is Orderings.xt3.
    
tts_lemma xt4:
  assumes "xU2. f x  U1"
    and "b  U2"
    and "a  U1"
    and "c  U2"
    and "f b <ow.1 a"
    and "c ow.2 b"
    and "x y. x  U2; y  U2; y ow.2 x  f y ow.1 f x"
  shows "f c <ow.1 a"
    is Orderings.xt4.
    
tts_lemma xt5:
  assumes "b  U1"
    and "a  U1"
    and "c  U2"
    and "xU1. f x  U2"
    and "b <ow.1 a"
    and "c ow.2 f b"
    and "x y. x  U1; y  U1; y <ow.1 x  f y <ow.2 f x"
  shows "c <ow.2 f a"
    is Orderings.xt5.
    
tts_lemma xt7:
  assumes "b  U1"
    and "a  U1"
    and "c  U2"
    and "xU1. f x  U2"
    and "b ow.1 a"
    and "c <ow.2 f b"
    and "x y. x  U1; y  U1; y ow.1 x  f y ow.2 f x"
  shows "c <ow.2 f a"
    is Orderings.xt7.

tts_lemma xt8:
  assumes "xU2. f x  U1"
    and "b  U2"
    and "a  U1"
    and "c  U2"
    and "f b <ow.1 a"
    and "c <ow.2 b"
    and "x y. x  U2; y  U2; y <ow.2 x  f y <ow.1 f x"
  shows "f c <ow.1 a"
    is Orderings.xt8.

tts_lemma xt9:
  assumes "b  U1"
    and "a  U1"
    and "c  U2"
    and "xU1. f x  U2"
    and "b <ow.1 a"
    and "c <ow.2 f b"
    and "x y. x  U1; y  U1; y <ow.1 x  f y <ow.2 f x"
  shows "c <ow.2 f a"
    is Orderings.xt9.

end

tts_context
  tts: (?'a to U1) and (?'b to U2)
  sbterms: ((≤)::[?'a::order, ?'a::order]  bool› to (≤ow.1)) 
    and ((<)::[?'a::order, ?'a::order]  bool› to (<ow.1))  
    and ((≤)::[?'b::order, ?'b::order]  bool› to (≤ow.2)) 
    and ((<)::[?'b::order, ?'b::order]  bool› to (<ow.2))
  rewriting ctr_simps
  substituting ord1.order_ow_axioms and ord2.order_ow_axioms
  eliminating through simp
begin

tts_lemma order_less_subst1:
  assumes "a  U1"
    and "xU2. f x  U1"
    and "b  U2"
    and "c  U2"
    and "a <ow.1 f b"
    and "b <ow.2 c"
    and "x y. x  U2; y  U2; x <ow.2 y  f x <ow.1 f y"
  shows "a <ow.1 f c"
    is Orderings.order_less_subst1.
    
tts_lemma order_subst1:
  assumes "a  U1"
    and "xU2. f x  U1"
    and "b  U2"
    and "c  U2"
    and "a ow.1 f b"
    and "b ow.2 c"
    and "x y. x  U2; y  U2; x ow.2 y  f x ow.1 f y"
  shows "a ow.1 f c"
    is Orderings.order_subst1.

end

tts_context
  tts: (?'a to U1) and (?'c to U2)
  sbterms: ((≤)::[?'a::order, ?'a::order]  bool› to (≤ow.1)) 
    and ((<)::[?'a::order, ?'a::order]  bool› to (<ow.1)) 
    and ((≤)::[?'c::order, ?'c::order]  bool› to (≤ow.2)) 
    and ((<)::[?'c::order, ?'c::order]  bool› to (<ow.2))
  rewriting ctr_simps
  substituting ord1.order_ow_axioms and ord2.order_ow_axioms
  eliminating through simp
begin

tts_lemma order_less_le_subst2:
  assumes "a  U1"
    and "b  U1"
    and "xU1. f x  U2"
    and "c  U2"
    and "a <ow.1 b"
    and "f b ow.2 c"
    and "x y. x  U1; y  U1; x <ow.1 y  f x <ow.2 f y"
  shows "f a <ow.2 c"
    is Orderings.order_less_le_subst2.
    
tts_lemma order_le_less_subst2:
  assumes "a  U1"
    and "b  U1"
    and "xU1. f x  U2"
    and "c  U2"
    and "a ow.1 b"
    and "f b <ow.2 c"
    and "x y. x  U1; y  U1; x ow.1 y  f x ow.2 f y"
  shows "f a <ow.2 c"
    is Orderings.order_le_less_subst2.
    
tts_lemma order_less_subst2:
  assumes "a  U1"
    and "b  U1"
    and "xU1. f x  U2"
    and "c  U2"
    and "a <ow.1 b"
    and "f b <ow.2 c"
    and "x y. x  U1; y  U1; x <ow.1 y  f x <ow.2 f y"
  shows "f a <ow.2 c"
    is Orderings.order_less_subst2.

tts_lemma order_subst2:
  assumes "a  U1"
    and "b  U1"
    and "xU1. f x  U2"
    and "c  U2"
    and "a ow.1 b"
    and "f b ow.2 c"
    and "x y. x  U1; y  U1; x ow.1 y  f x ow.2 f y"
  shows "f a ow.2 c"
    is Orderings.order_subst2.

end

end



subsection‹Dense orders›


subsubsection‹Definitions and common properties›

locale dense_order_ow = order_ow U le ls
  for U :: "'ao set" and le ls +
  assumes dense: " x  U; y  U; x <ow y   (zU. x <ow z  z <ow y)"


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma dense_order_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      (dense_order_ow (Collect (Domainp A))) class.dense_order"
  unfolding 
    dense_order_ow_def class.dense_order_def
    dense_order_ow_axioms_def class.dense_order_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp
  
end



subsection‹
Partial orders with the greatest element and 
partial orders with the least elements
›


subsubsection‹Definitions and common properties›

locale ordering_top_ow = ordering_ow U le ls 
  for U :: "'ao set" and le ls  +
  fixes top :: "'ao" ("ow")
  assumes top_closed[simp]: "ow  U"
  assumes extremum[simp]: "a  U  a ow ow"
begin

notation top ("ow")

end

locale bot_ow = 
  fixes U :: "'ao set" and bot (ow)
  assumes bot_closed[simp]: "ow  U"
begin

notation bot (ow)

end

locale bot_pair_ow = ord1: bot_ow U1 bot1 + ord2: bot_ow U2 bot2
  for U1 :: "'ao set" and bot1 and U2 :: "'bo set" and bot2
begin

notation bot1 (ow.1)
notation bot2 (ow.2)

end

locale order_bot_ow = order_ow U le ls + bot_ow U bot
  for U :: "'ao set" and bot le ls  +
  assumes bot_least: "a  U  ow ow a"
begin

sublocale bot: ordering_top_ow U (≥ow) (>ow) ow
  apply unfold_locales
  subgoal by simp
  subgoal by (simp add: bot_least)
  done

no_notation le (infix "ow" 50)
  and ls (infix "<ow" 50)
  and top ("ow")

end

locale order_bot_pair_ow = 
  ord1: order_bot_ow U1 bot1 le1 ls1 + ord2: order_bot_ow U2 bot2 le2 ls2 
  for U1 :: "'ao set" and bot1 le1 ls1 and U2 :: "'bo set" and bot2 le2 ls2  
begin

sublocale bot_pair_ow ..
sublocale order_pair_ow ..

end


locale top_ow = 
  fixes U :: "'ao set" and top (ow)
  assumes top_closed[simp]: "ow  U"
begin

notation top (ow)

end

locale top_pair_ow = ord1: top_ow U1 top1 + ord2: top_ow U2 top2
  for U1 :: "'ao set" and top1 and U2 :: "'bo set" and top2
begin

notation top1 (ow.1)
notation top2 (ow.2)

end

locale order_top_ow = order_ow U le ls + top_ow U top
  for U :: "'ao set" and le ls top  +
  assumes top_greatest: "a  U  a ow ow"
begin

sublocale top: ordering_top_ow U (≤ow) (<ow) ow
  apply unfold_locales
  subgoal by simp
  subgoal by (simp add: top_greatest)
  done

no_notation le (infix "ow" 50)
  and ls (infix "<ow" 50)
  and top ("ow")

end

locale order_top_pair_ow = 
  ord1: order_top_ow U1 le1 ls1 top1 + ord2: order_top_ow U2 le2 ls2 top2
  for U1 :: "'ao set" and le1 ls1 top1 and U2 :: "'bo set" and le2 ls2 top2 
begin

sublocale top_pair_ow ..
sublocale order_pair_ow ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma ordering_top_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=)) 
      (ordering_top_ow (Collect (Domainp A))) ordering_top"
proof-
  let ?P = "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=))"
  let ?ordering_top_ow = "ordering_top_ow (Collect (Domainp A))"
  have 
    "?P ?ordering_top_ow (λle ls ext. ext  UNIV  ordering_top le ls ext)"
    unfolding 
      ordering_top_ow_def ordering_top_def
      ordering_top_ow_axioms_def ordering_top_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by blast 
  thus ?thesis by simp
qed

lemma order_bot_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      (order_bot_ow (Collect (Domainp A))) class.order_bot"
proof-
  let ?P = "(A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=))"
  let ?order_bot_ow = "order_bot_ow (Collect (Domainp A))"
  have 
    "?P ?order_bot_ow (λbot le ls. bot  UNIV  class.order_bot bot le ls)"
    unfolding 
      class.order_bot_def order_bot_ow_def 
      class.order_bot_axioms_def order_bot_ow_axioms_def
      bot_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by blast 
  thus ?thesis by simp
qed

lemma order_top_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=)) 
      (order_top_ow (Collect (Domainp A))) class.order_top"
proof-
  let ?P = "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> (=))"
  let ?order_top_ow = "order_top_ow (Collect (Domainp A))"
  have 
    "?P ?order_top_ow (λle ls top. top  UNIV  class.order_top le ls top)"
    unfolding 
      class.order_top_def order_top_ow_def 
      class.order_top_axioms_def order_top_ow_axioms_def
      top_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by blast 
  thus ?thesis by simp
qed
  
end


subsubsection‹Relativization›

context ordering_top_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ordering_top_ow_axioms
  eliminating through simp
  applying [OF top_closed]
begin

tts_lemma extremum_uniqueI:
  assumes "ow ow ow"
  shows "ow = ow"
    is ordering_top.extremum_uniqueI.
    
tts_lemma extremum_unique:
  shows "(ow ow ow) = (ow = ow)"
    is ordering_top.extremum_unique.
    
tts_lemma extremum_strict:
  shows "¬ ow <ow ow"
    is ordering_top.extremum_strict.
    
tts_lemma not_eq_extremum:
  shows "(ow  ow) = (ow <ow ow)"
    is ordering_top.not_eq_extremum.

end
  
end

context order_bot_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting order_bot_ow_axioms
  eliminating through simp
begin

tts_lemma bdd_above_bot:
  assumes "A  U"
  shows "bdd_below A"
    is order_bot_class.bdd_above_bot.

tts_lemma not_less_bot:
  assumes "a  U"
  shows "¬ a <ow ow"
  is order_bot_class.not_less_bot.
    
tts_lemma max_bot:
  assumes "x  U"
  shows "max ow x = x"
    is order_bot_class.max_bot.

tts_lemma max_bot2:
  assumes "x  U"
  shows "max x ow = x"
    is order_bot_class.max_bot2.

tts_lemma min_bot:
  assumes "x  U"
  shows "min ow x = ow"
    is order_bot_class.min_bot.

tts_lemma min_bot2:
  assumes "x  U"
  shows "min x ow = ow"
    is order_bot_class.min_bot2.

tts_lemma bot_unique:
  assumes "a  U"
  shows "(a ow ow) = (a = ow)"
    is order_bot_class.bot_unique.

tts_lemma bot_less:
  assumes "a  U"
  shows "(a  ow) = (ow <ow a)"
    is order_bot_class.bot_less.

tts_lemma atLeast_eq_UNIV_iff:
  assumes "x  U"
  shows "({x..ow} = U) = (x = ow)"
    is order_bot_class.atLeast_eq_UNIV_iff.

tts_lemma le_bot:
  assumes "a  U" and "a ow ow"
  shows "a = ow"
    is order_bot_class.le_bot.

end

end

context order_top_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting order_top_ow_axioms
  eliminating through simp
begin

tts_lemma bdd_above_top:
  assumes "A  U"
  shows "bdd_above A"
  is order_top_class.bdd_above_top.

tts_lemma not_top_less:
  assumes "a  U"
  shows "¬ ow <ow a"
    is order_top_class.not_top_less.

tts_lemma max_top:
  assumes "x  U"
  shows "max ow x = ow"
    is order_top_class.max_top.

tts_lemma max_top2:
  assumes "x  U"
  shows "max x ow = ow"
    is order_top_class.max_top2.

tts_lemma min_top:
  assumes "x  U"
  shows "min ow x = x"
    is order_top_class.min_top.

tts_lemma min_top2:
  assumes "x  U"
  shows "min x ow = x"
    is order_top_class.min_top2.

tts_lemma top_unique:
  assumes "a  U"
  shows "(ow ow a) = (a = ow)"
    is order_top_class.top_unique.

tts_lemma less_top:
  assumes "a  U"
  shows "(a  ow) = (a <ow ow)"
    is order_top_class.less_top.

tts_lemma atMost_eq_UNIV_iff:
  assumes "x  U"
  shows "({..owx} = U) = (x = ow)"
    is order_top_class.atMost_eq_UNIV_iff.

tts_lemma top_le:
  assumes "a  U" and "ow ow a"
  shows "a = ow"
    is order_top_class.top_le.

end

end

text‹\newpage›

end

Theory SML_Semigroups

(* Title: Examples/SML_Relativization/Algebra/SML_Semigroups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about semigroups›
theory SML_Semigroups
  imports 
    "../SML_Introduction"
    "../Foundations/Lifting_Set_Ext"
begin



subsection‹Simple semigroups›


subsubsection‹Definitions and common properties›

locale semigroup_ow = 
  fixes U :: "'ag set" and f :: "['ag, 'ag]  'ag" (infixl *ow 70)
  assumes f_closed: " a  U; b  U   a *ow b  U"
  assumes assoc: " a  U; b  U; c  U   a *ow b *ow c = a *ow (b *ow c)"
begin

notation f (infixl *ow 70)

lemma f_closed'[simp]: "xU. yU. x *ow y  U" by (simp add: f_closed)

tts_register_sbts (*ow) | U by (rule tts_AA_A_transfer[OF f_closed])

end

lemma semigroup_ow: "semigroup = semigroup_ow UNIV"
  unfolding semigroup_def semigroup_ow_def by simp

locale plus_ow =
  fixes U :: "'ag set" and plus :: "['ag, 'ag]  'ag" (infixl +ow 65)
  assumes plus_closed[simp, intro]: " a  U; b  U   a +ow b  U"
begin

notation plus (infixl +ow 65)

lemma plus_closed'[simp]: "xU. yU. x +ow y  U" by simp

tts_register_sbts (+ow) | U  by (rule tts_AA_A_transfer[OF plus_closed])

end

locale times_ow =
  fixes U :: "'ag set" and times :: "['ag, 'ag]  'ag" (infixl *ow 70)
  assumes times_closed[simp, intro]: " a  U; b  U   a *ow b  U"
begin

notation times (infixl *ow 70)

lemma times_closed'[simp]: "xU. yU. x *ow y  U" by simp

tts_register_sbts (*ow) | U  by (rule tts_AA_A_transfer[OF times_closed])

end

locale semigroup_add_ow = plus_ow U plus 
  for U :: "'ag set" and plus +
  assumes plus_assoc: 
    " a  U; b  U; c  U   a +ow b +ow c = a +ow (b +ow c)"
begin

sublocale add: semigroup_ow U (+ow) 
  by unfold_locales (auto simp: plus_assoc)

end

lemma semigroup_add_ow: "class.semigroup_add = semigroup_add_ow UNIV"
  unfolding 
    class.semigroup_add_def semigroup_add_ow_def
    semigroup_add_ow_axioms_def plus_ow_def
  by simp

locale semigroup_mult_ow = times_ow U times 
  for U :: "'ag set" and times +
  assumes mult_assoc: 
    " a  U; b  U; c  U   a *ow b *ow c = a *ow (b *ow c)"
begin

sublocale mult: semigroup_ow U (*ow) 
  by unfold_locales (auto simp: times_closed' mult_assoc)

end

lemma semigroup_mult_ow: "class.semigroup_mult = semigroup_mult_ow UNIV"
  unfolding 
    class.semigroup_mult_def semigroup_mult_ow_def
    semigroup_mult_ow_axioms_def times_ow_def
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semigroup_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (semigroup_ow (Collect (Domainp A))) semigroup"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_ow = "semigroup_ow (Collect (Domainp A))"
  let ?rf_UNIV = 
    "(λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))"
  have "?P ?semigroup_ow (λf. ?rf_UNIV f  semigroup f)"
    unfolding semigroup_ow_def semigroup_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (semigroup_add_ow (Collect (Domainp A))) class.semigroup_add"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_add_ow = "(λf. semigroup_add_ow (Collect (Domainp A)) f)"
  let ?rf_UNIV = 
    "(λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))"
  have "?P ?semigroup_add_ow (λf. ?rf_UNIV f  class.semigroup_add f)"
    unfolding 
      semigroup_add_ow_def class.semigroup_add_def
      semigroup_add_ow_axioms_def plus_ow_def
    apply transfer_prover_start
    apply transfer_step+    
    by simp
  thus ?thesis by simp
qed

lemma semigroup_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (semigroup_mult_ow (Collect (Domainp A))) class.semigroup_mult"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_mult_ow = "(λf. semigroup_mult_ow (Collect (Domainp A)) f)"
  let ?rf_UNIV = 
    "(λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))"
  have "?P ?semigroup_mult_ow (λf. ?rf_UNIV f  class.semigroup_mult f)"
    unfolding 
      semigroup_mult_ow_def class.semigroup_mult_def
      semigroup_mult_ow_axioms_def times_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

end



subsection‹Cancellative semigroups›


subsubsection‹Definitions and common properties›
 
locale cancel_semigroup_add_ow = semigroup_add_ow U plus
  for U :: "'ag set" and plus +
  assumes add_left_imp_eq: 
    " a  U; b  U; c  U; a +ow b = a +ow c   b = c"
  assumes add_right_imp_eq: 
    " b  U; a  U; c  U; b +ow a = c +ow a   b = c"

lemma cancel_semigroup_add_ow: 
  "class.cancel_semigroup_add = cancel_semigroup_add_ow UNIV"
  unfolding 
    class.cancel_semigroup_add_def cancel_semigroup_add_ow_def
    cancel_semigroup_add_ow_axioms_def class.cancel_semigroup_add_axioms_def
    semigroup_add_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma cancel_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (cancel_semigroup_add_ow (Collect (Domainp A)))  
      class.cancel_semigroup_add"
  unfolding cancel_semigroup_add_ow_def class.cancel_semigroup_add_def
  unfolding 
    cancel_semigroup_add_ow_axioms_def class.cancel_semigroup_add_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end


subsubsection‹Relativization›

context cancel_semigroup_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_semigroup_add_ow_axioms
  eliminating through simp
begin

tts_lemma add_right_cancel:
  assumes "b  U" and "a  U" and "c  U"
  shows "(b +ow a = c +ow a) = (b = c)"
  is cancel_semigroup_add_class.add_right_cancel.

tts_lemma add_left_cancel:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a +ow b = a +ow c) = (b = c)"
  is cancel_semigroup_add_class.add_left_cancel.
    
tts_lemma bij_betw_add:
  assumes "a  U" and "A  U" and "B  U"
  shows "bij_betw ((+ow) a) A B = ((+ow) a ` A = B)"
    is cancel_semigroup_add_class.bij_betw_add.

tts_lemma inj_on_add:
  assumes "a  U" and "A  U"
  shows "inj_on ((+ow) a) A"
    is cancel_semigroup_add_class.inj_on_add.

tts_lemma inj_add_left:
  assumes "a  U"
  shows "inj_on ((+ow) a) U"
    is cancel_semigroup_add_class.inj_add_left.

tts_lemma inj_on_add':
  assumes "a  U" and "A  U"
  shows "inj_on (λb. b +ow a) A"
    is cancel_semigroup_add_class.inj_on_add'.

end

end



subsection‹Commutative semigroups›


subsubsection‹Definitions and common properties›

locale abel_semigroup_ow =
  semigroup_ow U f for U :: "'ag set" and f +
  assumes commute: " a  U; b  U   a *ow b = b *ow a"
begin

lemma fun_left_comm: 
  assumes "x  U" and "y  U" and "z  U" 
  shows "y *ow (x *ow z) = x *ow (y *ow z)"
  using assms by (metis assoc commute)

end

lemma abel_semigroup_ow: "abel_semigroup = abel_semigroup_ow UNIV"
  unfolding 
    abel_semigroup_def abel_semigroup_ow_def
    abel_semigroup_axioms_def abel_semigroup_ow_axioms_def
    semigroup_ow
  by simp

locale ab_semigroup_add_ow =
  semigroup_add_ow U plus for U :: "'ag set" and plus +
  assumes add_commute: " a  U; b  U   a +ow b = b +ow a"
begin

sublocale add: abel_semigroup_ow U (+ow) 
  by unfold_locales (rule add_commute)
  
end

lemma ab_semigroup_add_ow: "class.ab_semigroup_add = ab_semigroup_add_ow UNIV"
  unfolding 
    class.ab_semigroup_add_def ab_semigroup_add_ow_def
    class.ab_semigroup_add_axioms_def ab_semigroup_add_ow_axioms_def
    semigroup_add_ow
  by simp

locale ab_semigroup_mult_ow = 
  semigroup_mult_ow U times for U :: "'ag set" and times+
  assumes mult_commute: " a  U; b  U   a *ow b = b *ow a"
begin

sublocale mult: abel_semigroup_ow U (*ow) 
  by unfold_locales (rule mult_commute)
  
end

lemma ab_semigroup_mult_ow: 
  "class.ab_semigroup_mult = ab_semigroup_mult_ow UNIV"
  unfolding 
    class.ab_semigroup_mult_def ab_semigroup_mult_ow_def
    class.ab_semigroup_mult_axioms_def ab_semigroup_mult_ow_axioms_def
    semigroup_mult_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma abel_semigroup_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (abel_semigroup_ow (Collect (Domainp A))) abel_semigroup"
  unfolding 
    abel_semigroup_ow_def abel_semigroup_def
    abel_semigroup_ow_axioms_def abel_semigroup_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_def by simp

lemma ab_semigroup_add_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (ab_semigroup_add_ow (Collect (Domainp A))) class.ab_semigroup_add"
  unfolding 
    ab_semigroup_add_ow_def class.ab_semigroup_add_def
    ab_semigroup_add_ow_axioms_def class.ab_semigroup_add_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma ab_semigroup_mult_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (ab_semigroup_mult_ow (Collect (Domainp A))) class.ab_semigroup_mult"
  unfolding ab_semigroup_mult_ow_def class.ab_semigroup_mult_def
  unfolding ab_semigroup_mult_ow_axioms_def class.ab_semigroup_mult_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end


subsubsection‹Relativization›

context abel_semigroup_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting abel_semigroup_ow_axioms
  eliminating through simp
begin

tts_lemma left_commute:
  assumes "b  U" and "a  U" and "c  U"
  shows "b *ow (a *ow c) = a *ow (b *ow c)"
    is abel_semigroup.left_commute.

end

end

context ab_semigroup_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ab_semigroup_add_ow_axioms
  eliminating through simp
begin

tts_lemma add_ac:
  shows "a  U; b  U; c  U  a +ow b +ow c = a +ow (b +ow c)"
    is ab_semigroup_add_class.add_ac(1)
    and "a  U; b  U  a +ow b = b +ow a"
    is ab_semigroup_add_class.add_ac(2)
    and "b  U; a  U; c  U  b +ow (a +ow c) = a +ow (b +ow c)"
    is ab_semigroup_add_class.add_ac(3).

end

end

context ab_semigroup_mult_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ab_semigroup_mult_ow_axioms
  eliminating through simp
begin

tts_lemma mult_ac:
  shows "a  U; b  U; c  U  a *ow b *ow c = a *ow (b *ow c)"
    is ab_semigroup_mult_class.mult_ac(1)
    and "a  U; b  U  a *ow b = b *ow a"
    is ab_semigroup_mult_class.mult_ac(2)
    and "b  U; a  U; c  U  b *ow (a *ow c) = a *ow (b *ow c)"
    is ab_semigroup_mult_class.mult_ac(3).

end

end



subsection‹Cancellative commutative semigroups›


subsubsection‹Definitions and common properties›

locale minus_ow =
  fixes U :: "'ag set" and minus :: "['ag, 'ag]  'ag" (infixl -ow 65)
  assumes minus_closed[simp,intro]: " a  U; b  U   a -ow b  U"
begin

notation minus (infixl -ow 65)

lemma minus_closed'[simp]: "xU. yU. x -ow y  U" by simp

tts_register_sbts (-ow) | U by (rule tts_AA_A_transfer[OF minus_closed])

end

locale cancel_ab_semigroup_add_ow = 
  ab_semigroup_add_ow U plus + minus_ow U minus
  for U :: "'ag set" and plus minus +
  assumes add_diff_cancel_left'[simp]: 
    " a  U; b  U   (a +ow b) -ow a = b"
  assumes diff_diff_add: 
    " a  U; b  U; c  U   a -ow b -ow c = a -ow (b +ow c)"
begin

sublocale cancel_semigroup_add_ow U (+ow)
  apply unfold_locales
  subgoal by (metis add_diff_cancel_left')
  subgoal by (metis add.commute add_diff_cancel_left')
  done

end

lemma cancel_ab_semigroup_add_ow: 
  "class.cancel_ab_semigroup_add = cancel_ab_semigroup_add_ow UNIV"
  unfolding 
    class.cancel_ab_semigroup_add_def 
    cancel_ab_semigroup_add_ow_def
    class.cancel_ab_semigroup_add_axioms_def
    cancel_ab_semigroup_add_ow_axioms_def
    minus_ow_def
    ab_semigroup_add_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma cancel_ab_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=)) 
      (cancel_ab_semigroup_add_ow (Collect (Domainp A))) 
      class.cancel_ab_semigroup_add"
proof -
  let ?P = "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=))"
  let ?cancel_ab_semigroup_add_ow = 
    "cancel_ab_semigroup_add_ow (Collect (Domainp A))"
  let ?rf_UNIV = 
    "(λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))"
  have 
    "?P 
      ?cancel_ab_semigroup_add_ow 
      (λf fi. ?rf_UNIV fi  class.cancel_ab_semigroup_add f fi)"
    unfolding 
      class.cancel_ab_semigroup_add_def 
      cancel_ab_semigroup_add_ow_def
      class.cancel_ab_semigroup_add_axioms_def 
      cancel_ab_semigroup_add_ow_axioms_def
      minus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by auto
  thus ?thesis by simp
qed

end


subsubsection‹Relativization›

context cancel_ab_semigroup_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_ab_semigroup_add_ow_axioms
  eliminating through simp
begin

tts_lemma add_diff_cancel_right':
  assumes "a  U" and "b  U"
  shows "a +ow b -ow b = a"
    is cancel_ab_semigroup_add_class.add_diff_cancel_right'.

tts_lemma add_diff_cancel_right:
  assumes "a  U" and "c  U" and "b  U"
  shows "a +ow c -ow (b +ow c) = a -ow b"
    is cancel_ab_semigroup_add_class.add_diff_cancel_right.

tts_lemma add_diff_cancel_left:
  assumes "c  U" and "a  U" and "b  U"
  shows "c +ow a -ow (c +ow b) = a -ow b"
    is cancel_ab_semigroup_add_class.add_diff_cancel_left.

tts_lemma diff_right_commute:
  assumes "a  U" and "c  U" and "b  U"
  shows "a -ow c -ow b = a -ow b -ow c"
    is cancel_ab_semigroup_add_class.diff_right_commute.

tts_lemma diff_diff_eq:
  assumes "a  U" and "b  U" and "c  U"
  shows "a -ow b -ow c = a -ow (b +ow c)"
    is diff_diff_eq.

end

end

text‹\newpage›

end

Theory SML_Monoids

(* Title: Examples/SML_Relativization/Algebra/SML_Monoids.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about monoids›
theory SML_Monoids
  imports 
    SML_Semigroups
    "../Foundations/Product_Type_Ext"
    "../Foundations/Transfer_Ext"
begin



subsection‹Simple monoids›


subsubsection‹Definitions and common properties›

locale neutral_ow =
  fixes U :: "'ag set" and z :: "'ag" (1ow)
  assumes z_closed[simp]: "1ow  U" 
begin

notation z (1ow)

tts_register_sbts 1ow | U by (meson Domainp.cases z_closed)

lemma not_empty[simp]: "U  {}" using z_closed by blast

lemma neutral_map: "(λy. 1ow) ` A  U" using z_closed by auto

end

locale monoid_ow = semigroup_ow U f + neutral_ow U z
  for U :: "'ag set" and f z +
  assumes left_neutral_mow[simp]: "a  U  (1ow *ow a) = a"
    and right_neutral_mow[simp]: "a  U  (a *ow 1ow) = a"

locale zero_ow = zero: neutral_ow U zero
  for U :: "'ag set" and zero :: "'ag" (0ow)
begin

notation zero (0ow)

lemma zero_closed: "0ow  U" by (rule zero.z_closed)

end

lemma monoid_ow: "monoid = monoid_ow UNIV"
  unfolding 
    monoid_def monoid_ow_def monoid_axioms_def monoid_ow_axioms_def
    neutral_ow_def
    semigroup_ow
  by simp

locale one_ow = one: neutral_ow U one
  for U :: "'ag set" and one :: "'ag" (1ow)
begin

notation one (1ow)

lemma one_closed: "1ow  U" by (rule one.z_closed)

end

locale power_ow = one_ow U one + times_ow U times
  for U :: "'ag set" and one :: "'ag" (1ow) and times (infixl *ow 70)

primrec power_with :: "['a, ['a, 'a]  'a, 'a, nat]  'a"
  ('(/with _ _ : _ ^ow _/') [1000, 999, 1000, 1000] 10)
  where
    power_0: "power_with one times a 0 = one" for one times
  | power_Suc: "power_with one times a (Suc n) = 
      times a (power_with one times a n)" for one times

lemma power_with[ud_with]: "power = power_with 1 (*)"
  apply(intro ext)
  subgoal for x n by (induction n) auto
  done

context power_ow
begin

abbreviation power ((_ ^ow _) [81, 80] 80) where 
  "power  power_with 1ow (*ow)"

end

locale monoid_add_ow =
  semigroup_add_ow U plus + zero_ow U zero for U :: "'ag set" and plus zero +
  assumes add_0_left: "a  U  (0ow +ow a) = a"
  assumes add_0_right: "a  U  (a +ow 0ow) = a"
begin

sublocale add: monoid_ow U (+ow) 0ow 
  by unfold_locales (simp add: add_0_left add_0_right)+

end

lemma monoid_add_ow: "class.monoid_add = monoid_add_ow UNIV"
  unfolding 
    class.monoid_add_def monoid_add_ow_def
    class.monoid_add_axioms_def monoid_add_ow_axioms_def
    zero_ow_def neutral_ow_def
    semigroup_add_ow
  by simp

locale monoid_mult_ow = semigroup_mult_ow U times + one_ow U one 
  for U :: "'ag set" and one times  +
  assumes mult_1_left: "a  U  (1ow *ow a) = a"
  assumes mult_1_right: "a  U  (a *ow 1ow) = a"
begin

sublocale mult: monoid_ow U (*ow) 1ow 
  by unfold_locales (simp add: mult_1_left mult_1_right)+

sublocale power_ow ..

end

lemma monoid_mult_ow: "class.monoid_mult = monoid_mult_ow UNIV"
  unfolding 
    class.monoid_mult_def monoid_mult_ow_def
    class.monoid_mult_axioms_def monoid_mult_ow_axioms_def
    one_ow_def neutral_ow_def
    semigroup_mult_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma monoid_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (=)) 
      (monoid_ow (Collect (Domainp A))) monoid"
proof-
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?monoid_ow = "monoid_ow (Collect (Domainp A))"
  have "?P ?monoid_ow (λf z. z  UNIV  monoid f z)"
    unfolding 
      monoid_def monoid_ow_def 
      monoid_axioms_def monoid_ow_axioms_def 
      neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by blast
  thus ?thesis by simp
qed

lemma monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (=)) 
      (monoid_add_ow (Collect (Domainp A))) class.monoid_add"
proof-
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?monoid_add_ow = "monoid_add_ow (Collect (Domainp A))"
  have "?P ?monoid_add_ow (λf z. z  UNIV  class.monoid_add f z)"
    unfolding 
      class.monoid_add_def monoid_add_ow_def 
      class.monoid_add_axioms_def monoid_add_ow_axioms_def
      zero_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by blast
  thus ?thesis by simp
qed


lemma monoid_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(A ===> (A ===> A ===> A) ===> (=)) 
      (monoid_mult_ow (Collect (Domainp A))) class.monoid_mult"
proof-
  let ?P = "(A ===> (A ===> A ===> A) ===> (=))"
  let ?monoid_mult_ow = "monoid_mult_ow (Collect (Domainp A))"
  have "?P ?monoid_mult_ow (λz f. z  UNIV  class.monoid_mult z f)"
    unfolding 
      class.monoid_mult_def monoid_mult_ow_def 
      class.monoid_mult_axioms_def monoid_mult_ow_axioms_def
      one_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by blast
  thus ?thesis by simp
qed

lemma power_with_transfer[transfer_rule]:  
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(A ===> (A ===> A ===> A) ===> A ===> (=) ===> A) power_with power_with"
proof(intro rel_funI, elim subst)
  fix i i' m m' a a' n
  assume ii': "A i i'" and mm': "(A ===> A ===> A) m m'" and aa': "A a a'"
  show "A (power_with i m a n) (power_with i' m' a' n)"
    apply(induction n)
    subgoal by (simp add: ii')
    subgoal using mm' aa' by (auto elim: rel_funE)
    done
qed

end


subsubsection‹Relativization›

context power_ow
begin

tts_context
  tts: (?'a to U)
  sbterms: ((*)::[?'a::power,?'a::power]  ?'a::power› to (*ow)) 
    and (1::?'a::power› to 1ow)
  rewriting ctr_simps
  substituting power_ow_axioms and one.not_empty
begin

tts_lemma power_Suc:
  assumes "a  U"
  shows "a ^ow Suc n = a *ow a ^ow n"
    is power_class.power.power_Suc.

tts_lemma power_0:
  assumes "a  U"
  shows "a ^ow 0 = 1ow"
  is power_class.power.power_0.
    
tts_lemma power_eq_if:
  assumes "p  U"
  shows "p ^ow m = (if m = 0 then 1ow else p *ow p ^ow (m - 1))"
    is power_class.power_eq_if.
    
tts_lemma simps:
  assumes "a  U"
  shows "a ^ow 0 = 1ow" 
    is power_class.power.simps(1)
    and "a ^ow Suc n = a *ow a ^ow n" 
    is power_class.power.simps(2).

end

end

context monoid_mult_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting monoid_mult_ow_axioms and one.not_empty
  applying [OF one_closed mult.f_closed']
begin

tts_lemma power_commuting_commutes:
  assumes "x  U" and "y  U" and "x *ow y = y *ow x"
  shows "x ^ow n *ow y = y *ow x ^ow n"
    is monoid_mult_class.power_commuting_commutes.

tts_lemma left_right_inverse_power:
  assumes "x  U" and "y  U" and "x *ow y = 1ow"
  shows "x ^ow n *ow y ^ow n = 1ow"
    is monoid_mult_class.left_right_inverse_power.

tts_lemma power_numeral_even:
  assumes "z  U"
  shows "z ^ow numeral (num.Bit0 w) = (let w = z ^ow numeral w in w *ow w)"
    is monoid_mult_class.power_numeral_even.

tts_lemma power_numeral_odd:
  assumes "z  U"
  shows "z ^ow numeral (num.Bit1 w) = (let w = z ^ow numeral w in z *ow w *ow w)"
    is monoid_mult_class.power_numeral_odd.

tts_lemma power_minus_mult:
  assumes "a  U" and "0 < n"
  shows "a ^ow (n - 1) *ow a = a ^ow n"
    is monoid_mult_class.power_minus_mult.

tts_lemma power_Suc0_right:
  assumes "a  U" 
  shows "a ^ow Suc 0 = a"
    is monoid_mult_class.power_Suc0_right.

tts_lemma power2_eq_square:
  assumes "a  U"
  shows "a ^ow 2 = a *ow a"
    is monoid_mult_class.power2_eq_square.

tts_lemma power_one_right:
  assumes "a  U"
  shows "a ^ow 1 = a"
    is monoid_mult_class.power_one_right.

tts_lemma power_commutes:
  assumes "a  U"
  shows "a ^ow n *ow a = a *ow a ^ow n"
    is monoid_mult_class.power_commutes.

tts_lemma power3_eq_cube:
  assumes "a  U"
  shows "a ^ow 3 = a *ow a *ow a"
    is monoid_mult_class.power3_eq_cube.

tts_lemma power_even_eq:
  assumes "a  U"
  shows "a ^ow (2 * n) = (a ^ow n) ^ow 2"
    is monoid_mult_class.power_even_eq.

tts_lemma power_odd_eq:
  assumes "a  U"
  shows "a ^ow Suc (2 * n) = a *ow (a ^ow n) ^ow 2"
    is monoid_mult_class.power_odd_eq.

tts_lemma power_mult:
  assumes "a  U"
  shows "a ^ow (m * n) = (a ^ow m) ^ow n"
    is monoid_mult_class.power_mult.

tts_lemma power_Suc2:
  assumes "a  U"
  shows "a ^ow Suc n = a ^ow n *ow a"
    is monoid_mult_class.power_Suc2.

tts_lemma power_one: "1ow ^ow n = 1ow"
  is monoid_mult_class.power_one.

tts_lemma power_add:
  assumes "a  U"
  shows "a ^ow (m + n) = a ^ow m *ow a ^ow n"
    is monoid_mult_class.power_add.

tts_lemma power_mult_numeral:
  assumes "a  U"
  shows "(a ^ow numeral m) ^ow numeral n = a ^ow numeral (m * n)"
    is Power.power_mult_numeral.

tts_lemma power_add_numeral2:
  assumes "a  U" and "b  U"
  shows 
    "a ^ow numeral m *ow (a ^ow numeral n *ow b) = a ^ow numeral (m + n) *ow b"
    is Power.power_add_numeral2.

tts_lemma power_add_numeral:
  assumes "a  U"
  shows "a ^ow numeral m *ow a ^ow numeral n = a ^ow numeral (m + n)"
    is Power.power_add_numeral.

end

end



subsection‹Commutative monoids›


subsubsection‹Definitions and common properties›

locale comm_monoid_ow = 
  abel_semigroup_ow U f + neutral_ow U z for U :: "'ag set" and f z +
  assumes comm_neutral: "a  U  (a *ow 1ow) = a"
begin

sublocale monoid_ow U (*ow) 1ow
  apply unfold_locales
  subgoal by (simp add: comm_neutral commute)
  subgoal using commute by (simp add: comm_neutral)
  done

end

lemma comm_monoid_ow: "comm_monoid = comm_monoid_ow UNIV"
  unfolding 
    comm_monoid_def comm_monoid_ow_def
    comm_monoid_axioms_def comm_monoid_ow_axioms_def
    neutral_ow_def
    abel_semigroup_ow
  by simp

locale comm_monoid_set_ow = comm_monoid_ow U f z for U :: "'ag set" and f z
begin

tts_register_sbts (*ow) | U by (rule tts_AA_A_transfer[OF f_closed])
                        
end

lemma comm_monoid_set_ow: "comm_monoid_set = comm_monoid_set_ow UNIV"
  unfolding comm_monoid_set_def comm_monoid_set_ow_def comm_monoid_ow by simp

locale comm_monoid_add_ow =
  ab_semigroup_add_ow U plus + zero_ow U zero   
  for U :: "'ag set" and plus zero +
  assumes add_0[simp]: "a  U  0ow +ow a = a"
begin

sublocale add: comm_monoid_ow U (+ow) 0ow
  by unfold_locales (use add.commute in force)

sublocale monoid_add_ow U (+ow) 0ow by unfold_locales simp+ 

sublocale sum: comm_monoid_set_ow U (+ow) 0ow ..

notation sum.F («sum»)

abbreviation Sum (ow/ _› [1000] 1000)
  where "ow A  («sum» (λx. x) A)"

notation Sum (ow/ _› [1000] 1000)

end

lemma comm_monoid_add_ow: "class.comm_monoid_add = comm_monoid_add_ow UNIV"
  unfolding 
    class.comm_monoid_add_def comm_monoid_add_ow_def
    class.comm_monoid_add_axioms_def comm_monoid_add_ow_axioms_def
    zero_ow_def neutral_ow_def
    ab_semigroup_add_ow
  by simp

locale dvd_ow = times_ow U times 
  for U :: "'ag set" and times

ud ‹dvd.dvd›
ud dvd' ‹dvd_class.dvd›

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "bi_unique A" "right_total A"
  trp (?'a A)
  in dvd_ow': dvd.with_def 
    ((on _ with _: _ «dvd» _) [1000, 1000, 1000, 1000] 50)

ctr parametricity
  in dvd_ow'': dvd_ow'_def 

context dvd_ow
begin

abbreviation dvd (infixr «dvd» 50) where "a «dvd» b  dvd_ow' U (*ow) a b"
notation dvd (infixr «dvd» 50)

end

locale comm_monoid_mult_ow =
  ab_semigroup_mult_ow U times + one_ow U one 
  for U :: "'ag set" and times one +
  assumes mult_1[simp]: "a  U  1ow *ow a = a"
begin

sublocale dvd_ow ..

sublocale mult: comm_monoid_ow U (*ow) 1ow
  by unfold_locales (use mult.commute in force)

sublocale monoid_mult_ow U 1ow (*ow) by unfold_locales simp+ 

sublocale prod: comm_monoid_set_ow U (*ow) 1ow ..

notation prod.F («prod»)

abbreviation Prod (ow _› [1000] 1000)
  where "ow A  («prod» (λx. x) A)"

notation Prod (ow _› [1000] 1000)

end

lemma comm_monoid_mult_ow: "class.comm_monoid_mult = comm_monoid_mult_ow UNIV"
  unfolding 
    class.comm_monoid_mult_def comm_monoid_mult_ow_def
    class.comm_monoid_mult_axioms_def comm_monoid_mult_ow_axioms_def  
    one_ow_def neutral_ow_def
    ab_semigroup_mult_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma bij_betw_transfer[transfer_rule]:
  assumes [transfer_rule]:
    "bi_unique A" "right_total A" "bi_unique B" "right_total B" 
  shows 
    "((A ===> B) ===> rel_set A ===> rel_set B ===> (=)) bij_betw bij_betw"
  unfolding bij_betw_def inj_on_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma comm_monoid_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "((A ===> A ===> A) ===> A ===> (=)) 
      (comm_monoid_ow (Collect (Domainp A))) comm_monoid"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?comm_monoid_ow = "comm_monoid_ow (Collect (Domainp A))"
  have "?P ?comm_monoid_ow 
    (λf z. z  UNIV  comm_monoid f z)"
    unfolding 
      comm_monoid_ow_def comm_monoid_def  
      comm_monoid_ow_axioms_def comm_monoid_axioms_def 
      neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma comm_monoid_set_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (=)) 
      (comm_monoid_set_ow (Collect (Domainp A))) comm_monoid_set"
  unfolding comm_monoid_set_ow_def comm_monoid_set_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma comm_monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (=)) 
      (comm_monoid_add_ow (Collect (Domainp A))) class.comm_monoid_add"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?comm_monoid_add_ow = "comm_monoid_add_ow (Collect (Domainp A))"
  have "?P ?comm_monoid_add_ow (λf z. z  UNIV  class.comm_monoid_add f z)"
    unfolding 
      comm_monoid_add_ow_def class.comm_monoid_add_def 
      zero_ow_def neutral_ow_def 
      comm_monoid_add_ow_axioms_def class.comm_monoid_add_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma comm_monoid_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (=)) 
      (comm_monoid_mult_ow (Collect (Domainp A))) class.comm_monoid_mult"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (=))"
  let ?comm_monoid_mult_ow = "comm_monoid_mult_ow (Collect (Domainp A))"
  have "?P ?comm_monoid_mult_ow (λf z. z  UNIV  class.comm_monoid_mult f z)"
    unfolding 
      comm_monoid_mult_ow_def class.comm_monoid_mult_def 
      one_ow_def neutral_ow_def 
      comm_monoid_mult_ow_axioms_def class.comm_monoid_mult_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma dvd_with_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> A ===> (=)) 
      (dvd_ow' (Collect (Domainp A))) dvd.with"
  unfolding dvd_ow'_def dvd.with_def by transfer_prover

end


subsubsection‹Relativization›

context dvd_ow
begin

tts_context
  tts: (?'a to U)
  sbterms: ((*)::[?'a::times, ?'a::times]  ?'a::times› to (*ow))
  rewriting ctr_simps
  substituting dvd_ow_axioms 
  eliminating through simp
begin

tts_lemma dvdI:
  assumes "b  U" and "k  U" and "a = b *ow k"
  shows "b «dvd» a"
    is dvd_class.dvdI.

tts_lemma dvdE:
  assumes "b  U" 
    and "a  U" 
    and "b «dvd» a" 
    and "k. k  U; a = b *ow k  P"
  shows P
    is dvd_class.dvdE.

end

end

context comm_monoid_mult_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_monoid_mult_ow_axioms and one.not_empty
  applying [OF mult.f_closed' one_closed]
begin

tts_lemma strict_subset_divisors_dvd:
  assumes "a  U" and "b  U"
  shows 
    "({x  U. x «dvd» a}  {x  U. x «dvd» b}) = (a «dvd» b  ¬ b «dvd» a)"
    is comm_monoid_mult_class.strict_subset_divisors_dvd.

tts_lemma subset_divisors_dvd:
  assumes "a  U" and "b  U"
  shows "({x  U. x «dvd» a}  {x  U. x «dvd» b}) = (a «dvd» b)"
    is comm_monoid_mult_class.subset_divisors_dvd.

tts_lemma power_mult_distrib:
  assumes "a  U" and "b  U"
  shows "(a *ow b) ^ow n = a ^ow n *ow b ^ow n"
    is Power.comm_monoid_mult_class.power_mult_distrib.

tts_lemma dvd_triv_right:
  assumes "a  U" and "b  U"
  shows "a «dvd» b *ow a"
    is comm_monoid_mult_class.dvd_triv_right.

tts_lemma dvd_mult_right:
  assumes "a  U" and "b  U" and "c  U" and "a *ow b «dvd» c"
  shows "b «dvd» c"
    is comm_monoid_mult_class.dvd_mult_right.

tts_lemma mult_dvd_mono:
  assumes "a  U" 
    and "b  U" 
    and "c  U" 
    and "d  U"
    and "a «dvd» b"
    and "c «dvd» d"
  shows "a *ow c «dvd» b *ow d"
    is comm_monoid_mult_class.mult_dvd_mono.

tts_lemma dvd_triv_left:
  assumes "a  U" and "b  U"
  shows "a «dvd» a *ow b"
    is comm_monoid_mult_class.dvd_triv_left.

tts_lemma dvd_mult_left:
  assumes "a  U" and "b  U" and "c  U" and "a *ow b «dvd» c"
  shows "a «dvd» c"
    is comm_monoid_mult_class.dvd_mult_left.

tts_lemma dvd_trans:
  assumes "a  U" and "b  U" and "c  U" and "a «dvd» b" and "b «dvd» c"
  shows "a «dvd» c"
    is comm_monoid_mult_class.dvd_trans.

tts_lemma dvd_mult2:
  assumes "a  U" and "b  U" and "c  U" and "a «dvd» b"
  shows "a «dvd» b *ow c"
    is comm_monoid_mult_class.dvd_mult2.

tts_lemma dvd_refl:
  assumes "a  U"
  shows "a «dvd» a"
    is comm_monoid_mult_class.dvd_refl.

tts_lemma dvd_mult:
  assumes "a  U" and "c  U" and "b  U" and "a «dvd» c"
  shows "a «dvd» b *ow c"
    is comm_monoid_mult_class.dvd_mult.

tts_lemma one_dvd:
  assumes "a  U"
  shows "1ow «dvd» a"
    is comm_monoid_mult_class.one_dvd.

end

end



subsection‹Cancellative commutative monoids›


subsubsection‹Definitions and common properties›

locale cancel_comm_monoid_add_ow =
  cancel_ab_semigroup_add_ow U plus minus +
  comm_monoid_add_ow U plus zero
  for U :: "'ag set" and plus minus zero

lemma cancel_comm_monoid_add_ow: 
  "class.cancel_comm_monoid_add = cancel_comm_monoid_add_ow UNIV"
  unfolding 
    class.cancel_comm_monoid_add_def cancel_comm_monoid_add_ow_def
    cancel_ab_semigroup_add_ow comm_monoid_add_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma cancel_comm_monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (=)) 
      (cancel_comm_monoid_add_ow (Collect (Domainp A))) 
      class.cancel_comm_monoid_add"
  unfolding cancel_comm_monoid_add_ow_def class.cancel_comm_monoid_add_def
  by transfer_prover

end


subsubsection‹Relativization›

context cancel_comm_monoid_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_comm_monoid_add_ow_axioms and zero.not_empty
  applying [OF add.f_closed' minus_closed' zero_closed]
begin

tts_lemma add_cancel_right_right:
  assumes "a  U" and "b  U"
  shows "(a = a +ow b) = (b = 0ow)"
    is cancel_comm_monoid_add_class.add_cancel_right_right.
    
tts_lemma add_cancel_right_left:
  assumes "a  U" and "b  U"
  shows "(a = b +ow a) = (b = 0ow)"
    is cancel_comm_monoid_add_class.add_cancel_right_left.

tts_lemma add_cancel_left_right:
  assumes "a  U" and "b  U"
  shows "(a +ow b = a) = (b = 0ow)"
    is cancel_comm_monoid_add_class.add_cancel_left_right.

tts_lemma add_cancel_left_left:
  assumes "b  U" and "a  U"
  shows "(b +ow a = a) = (b = 0ow)"
    is cancel_comm_monoid_add_class.add_cancel_left_left.

tts_lemma add_implies_diff:
  assumes "c  U" and "b  U" and "a  U" and "c +ow b = a"
  shows "c = a -ow b"
    is cancel_comm_monoid_add_class.add_implies_diff.

tts_lemma diff_cancel:
  assumes "a  U"
  shows "a -ow a = 0ow"
    is cancel_comm_monoid_add_class.diff_cancel.

tts_lemma diff_zero:
  assumes "a  U"
  shows "a -ow 0ow = a"
    is cancel_comm_monoid_add_class.diff_zero.

end

end

text‹\newpage›

end

Theory SML_Groups

(* Title: Examples/SML_Relativization/Algebra/SML_Groups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about groups›
theory SML_Groups
  imports SML_Monoids
begin



subsection‹Simple groups›


subsubsection‹Definitions and common properties›

locale group_ow = semigroup_ow U f for U :: "'ag set" and f +
  fixes z (1ow)
    and inverse :: "'ag  'ag"
  assumes z_closed[simp]: "1ow  U"
    and inverse_closed[simp]: "a  U  inverse a  U" 
    and group_left_neutral: "a  U  1ow *ow a = a"
    and left_inverse[simp]: "a  U  inverse a *ow a = 1ow"
begin

notation z (1ow)

lemma inverse_closed': "inverse ` U  U" by auto
lemma inverse_closed'': "xU. inverse x  U" by auto

lemma left_cancel: 
  assumes "a  U" and "b  U" and "c  U" 
  shows "a *ow b = a *ow c  b = c"
proof
  assume "a *ow b = a *ow c"
  then have "inverse a *ow (a *ow b) = inverse a *ow (a *ow c)" by simp
  with assms have "(inverse a *ow a) *ow b = (inverse a *ow a) *ow c"
    by (metis assoc inverse_closed) 
  with assms show "b = c" 
    using group_ow_axioms by (fastforce simp: group_ow.group_left_neutral)
qed simp

sublocale monoid_ow U (*ow) 1ow
proof
  show "a  U  a *ow 1ow = a" for a
  proof-
    assume "a  U" 
    with left_inverse[OF this] have "inverse a *ow (a *ow 1ow) = inverse a *ow a"
      by (metis assoc group_left_neutral inverse_closed z_closed)
    with a  U z_closed show "a *ow 1ow = a"
      by (meson left_cancel f_closed inverse_closed)
  qed
qed (simp add: group_left_neutral)+

lemma inverse_image[simp]: "inverse ` U  U" by (simp add: image_subsetI)

end

lemma group_ow: "group = group_ow UNIV"
  unfolding 
    group_def group_ow_def  group_axioms_def group_ow_axioms_def semigroup_ow
  by simp

locale uminus_ow =
  fixes U :: "'ag set" and uminus :: "'ag  'ag" (-ow _› [81] 80) 
  assumes uminus_closed: "a  U  -ow a  U"
begin

notation uminus (-ow _› [81] 80)

lemma uminus_closed': "uminus ` U  U" by (auto simp: uminus_closed)
lemma uminus_closed'': "aU. -ow a  U" by (simp add: uminus_closed)

tts_register_sbts uminus | U by (rule tts_AB_transfer[OF uminus_closed'])

end

locale group_add_ow =
  minus_ow U minus + uminus_ow U uminus + monoid_add_ow U plus zero
  for U :: "'ag set" and minus plus zero uminus +
  assumes left_inverse: "a  U  (-ow a) +ow a = 0ow"
    and add_inv_conv_diff: " a  U; b  U   a +ow (-ow b) = a -ow b"
begin

sublocale add: group_ow U (+ow) 0ow uminus
  by unfold_locales (auto simp: uminus_closed left_inverse)

lemma inverse_unique:
  assumes "a  U" and "b  U" and "a +ow b = 0ow"
  shows "-ow a = b"
proof-
  from assms have "(-ow a +ow a) +ow b = -ow a"
    by (metis add.assoc uminus_closed add.right_neutral_mow) 
  thus ?thesis 
    unfolding left_inverse[OF a  U] add.left_neutral_mow[OF b  U] by simp
qed

lemma inverse_neutral[simp]: "-ow 0ow = 0ow"
  by 
    (
      rule inverse_unique[
        OF zero_closed zero_closed add.left_neutral_mow[OF zero_closed]
        ]                                     
    )

lemma inverse_inverse: 
  assumes "a  U"
  shows "-ow (-ow a) = a"
  by 
    (
      rule inverse_unique[
        OF uminus_closed[OF assms] assms left_inverse[OF assms]
      ]
    )

lemma right_inverse: 
  assumes "a  U"
  shows "a +ow (-ow a) = 0ow"
proof -
  from assms have "a +ow (-ow a) = -ow (-ow a) +ow (-ow a)"
    by (simp add: inverse_inverse)
  moreover have " = 0ow" by (rule left_inverse[OF uminus_closed[OF assms]])
  ultimately show ?thesis by simp
qed

sublocale cancel_semigroup_add_ow U (+ow)
proof
  fix a b c assume "a  U" and "b  U" and "c  U" and "a +ow b = a +ow c"
  from a  U b  U c  U this have 
    "((-ow a) +ow a) +ow b = ((-ow a) +ow a) +ow c"
    by (auto simp: add.left_cancel)
  thus "b = c" 
    unfolding
      left_inverse[OF a  U]
      add.left_neutral_mow[OF b  U] 
      add.left_neutral_mow[OF c  U]
    by simp
next
  fix a b c assume "a  U" and "b  U" and "c  U" and "b +ow a = c +ow a"
  then have "b +ow (a +ow (-ow a)) = c +ow (a +ow (-ow a))" 
    by (metis add.assoc uminus_closed)
  thus "b = c"
    unfolding 
      right_inverse[OF a  U]
      add.left_neutral_mow[OF b  U] 
      add.right_neutral_mow[OF c  U]
    by (simp add: b  U)
qed

end

lemma group_add_ow: "class.group_add = group_add_ow UNIV"
  unfolding 
    class.group_add_def group_add_ow_def
    class.group_add_axioms_def group_add_ow_axioms_def
    minus_ow_def uminus_ow_def
    monoid_add_ow 
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma group_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "((A ===> A ===> A) ===> A ===> (A ===> A) ===> (=)) 
    (group_ow (Collect (Domainp A))) group"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (A ===> A) ===> (=))"
  let ?group_ow = "group_ow (Collect (Domainp A))"
  have 
    "?P 
      (λf z inv. ?group_ow f z inv) 
      (λf z inv. z  UNIV  (xUNIV. inv x  UNIV)  group f z inv)"
    unfolding group_ow_def group_def group_ow_axioms_def group_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

lemma group_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (A ===> A) ===> (=)) 
      (group_add_ow (Collect (Domainp A))) class.group_add"
proof -
  let ?P = 
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (A ===> A) ===> (=))"
  let ?group_add_ow = "group_add_ow (Collect (Domainp A))"
  have 
    "?P 
      (λminus plus zero uminus. ?group_add_ow minus plus zero uminus) 
      (
        λfi f z inv_f. 
          (xUNIV. yUNIV. fi x y  UNIV) 
          (xUNIV. inv_f x  UNIV)   
          class.group_add fi f z inv_f
      )"
    unfolding 
      group_add_ow_def class.group_add_def
      group_add_ow_axioms_def class.group_add_axioms_def
      minus_ow_def uminus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

end


subsubsection‹Relativization›

context group_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting group_ow_axioms and not_empty
  applying [OF f_closed' z_closed inverse_closed'']
begin

tts_lemma inverse_neutral: "inverse 1ow = 1ow"
  is group.inverse_neutral.
    
tts_lemma inverse_inverse:
  assumes "a  U"
  shows "inverse (inverse a) = a"
    is group.inverse_inverse.

tts_lemma right_inverse:
  assumes "a  U"
  shows "a *ow inverse a = 1ow"
    is group.right_inverse.

tts_lemma inverse_distrib_swap:
  assumes "a  U" and "b  U"
  shows "inverse (a *ow b) = inverse b *ow inverse a"
    is group.inverse_distrib_swap.

tts_lemma right_cancel:
  assumes "b  U" and "a  U" and "c  U"
  shows "(b *ow a = c *ow a) = (b = c)"
    is group.right_cancel.

tts_lemma inverse_unique:
  assumes "a  U" and "b  U" and "a *ow b = 1ow"
  shows "inverse a = b"
    is group.inverse_unique.
end

end

context group_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting group_add_ow_axioms and zero.not_empty
  applying [OF minus_closed' plus_closed' zero_closed add.inverse_closed'']
begin

tts_lemma diff_0:
  assumes "a  U"
  shows "0ow -ow a = -ow a"
    is group_add_class.diff_0.

tts_lemma diff_0_right:
  assumes "a  U"
  shows "a -ow 0ow = a"
    is group_add_class.diff_0_right.
    
tts_lemma diff_self:
  assumes "a  U"
  shows "a -ow a = 0ow"
    is group_add_class.diff_self.
    
tts_lemma group_left_neutral:
  assumes "a  U"
  shows "0ow +ow a = a"
    is group_add_class.add.group_left_neutral.
    
tts_lemma minus_minus:
  assumes "a  U"
  shows "-ow (-ow a) = a"
  is group_add_class.minus_minus.
    
tts_lemma right_minus:
  assumes "a  U"
  shows "a +ow -ow a = 0ow"
  is group_add_class.right_minus.

tts_lemma left_minus:
  assumes "a  U"
  shows "-ow a +ow a = 0ow"
    is group_add_class.left_minus.
    
tts_lemma add_diff_cancel:
  assumes "a  U" and "b  U"
  shows "a +ow b -ow b = a"
  is group_add_class.add_diff_cancel.
    
tts_lemma diff_add_cancel:
  assumes "a  U" and "b  U"
  shows "a -ow b +ow b = a"
    is group_add_class.diff_add_cancel.
    
tts_lemma diff_conv_add_uminus:
  assumes "a  U" and "b  U"
  shows "a -ow b = a +ow -ow b"
    is group_add_class.diff_conv_add_uminus.
    
tts_lemma diff_minus_eq_add:
  assumes "a  U" and "b  U"
  shows "a -ow -ow b = a +ow b"
    is group_add_class.diff_minus_eq_add.
  
tts_lemma add_uminus_conv_diff:
  assumes "a  U" and "b  U"
  shows "a +ow -ow b = a -ow b"
    is group_add_class.add_uminus_conv_diff.

tts_lemma minus_diff_eq:
  assumes "a  U" and "b  U"
  shows "-ow (a -ow b) = b -ow a"
    is group_add_class.minus_diff_eq.

tts_lemma add_minus_cancel:
  assumes "a  U" and "b  U"
  shows "a +ow (-ow a +ow b) = b"
    is group_add_class.add_minus_cancel.
    
tts_lemma minus_add_cancel:
  assumes "a  U" and "b  U"
  shows "-ow a +ow (a +ow b) = b"
    is group_add_class.minus_add_cancel.

tts_lemma neg_0_equal_iff_equal:
  assumes "a  U"
  shows "(0ow = -ow a) = (0ow = a)"
    is group_add_class.neg_0_equal_iff_equal.
    
tts_lemma neg_equal_0_iff_equal:
  assumes "a  U"
  shows "(-ow a = 0ow) = (a = 0ow)"
    is group_add_class.neg_equal_0_iff_equal.
    
tts_lemma eq_iff_diff_eq_0:
  assumes "a  U" and "b  U"
  shows "(a = b) = (a -ow b = 0ow)"
    is group_add_class.eq_iff_diff_eq_0.

tts_lemma equation_minus_iff:
  assumes "a  U" and "b  U"
  shows "(a = -ow b) = (b = -ow a)"
    is group_add_class.equation_minus_iff.

tts_lemma minus_equation_iff:
  assumes "a  U" and "b  U"
  shows "(-ow a = b) = (-ow b = a)"
    is group_add_class.minus_equation_iff.

tts_lemma neg_equal_iff_equal:
  assumes "a  U" and "b  U"
  shows "(-ow a = -ow b) = (a = b)"
    is group_add_class.neg_equal_iff_equal.

tts_lemma right_minus_eq:
  assumes "a  U" and "b  U"
  shows "(a -ow b = 0ow) = (a = b)"
    is group_add_class.right_minus_eq.

tts_lemma minus_add:
  assumes "a  U" and "b  U"
  shows "-ow (a +ow b) = -ow b +ow -ow a"
    is group_add_class.minus_add.

tts_lemma eq_neg_iff_add_eq_0:
  assumes "a  U" and "b  U"
  shows "(a = -ow b) = (a +ow b = 0ow)"
    is group_add_class.eq_neg_iff_add_eq_0.

tts_lemma neg_eq_iff_add_eq_0:
  assumes "a  U" and "b  U"
  shows "(-ow a = b) = (a +ow b = 0ow)"
    is group_add_class.neg_eq_iff_add_eq_0.

tts_lemma add_eq_0_iff2:
  assumes "a  U" and "b  U"
  shows "(a +ow b = 0ow) = (a = -ow b)"
    is group_add_class.add_eq_0_iff2.

tts_lemma add_eq_0_iff:
  assumes "a  U" and "b  U"
  shows "(a +ow b = 0ow) = (b = -ow a)"
    is group_add_class.add_eq_0_iff.

tts_lemma diff_diff_eq2:
  assumes "a  U" and "b  U" and "c  U"
  shows "a -ow (b -ow c) = a +ow c -ow b"
    is group_add_class.diff_diff_eq2.

tts_lemma diff_add_eq_diff_diff_swap:
  assumes "a  U" and "b  U" and "c  U"
  shows "a -ow (b +ow c) = a -ow c -ow b"
    is group_add_class.diff_add_eq_diff_diff_swap.

tts_lemma add_diff_eq:
  assumes "a  U" and "b  U" and "c  U"
  shows "a +ow (b -ow c) = a +ow b -ow c"
    is group_add_class.add_diff_eq.

tts_lemma eq_diff_eq:
  assumes "a  U" and "c  U" and "b  U"
  shows "(a = c -ow b) = (a +ow b = c)"
    is group_add_class.eq_diff_eq.

tts_lemma diff_eq_eq:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a -ow b = c) = (a = c +ow b)"
    is group_add_class.diff_eq_eq.

tts_lemma left_cancel:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a +ow b = a +ow c) = (b = c)"
    is group_add_class.add.left_cancel.

tts_lemma right_cancel:
  assumes "b  U" and "a  U" and "c  U"
  shows "(b +ow a = c +ow a) = (b = c)"
    is group_add_class.add.right_cancel.

tts_lemma minus_unique:
  assumes "a  U" and "b  U" and "a +ow b = 0ow"
  shows "-ow a = b"
    is group_add_class.minus_unique.

tts_lemma diff_eq_diff_eq:
  assumes "a  U" and "b  U" and "c  U" and "d  U" and "a -ow b = c -ow d"
  shows "(a = b) = (c = d)"
    is group_add_class.diff_eq_diff_eq.

end

end



subsection‹Abelian groups›


subsubsection‹Definitions and common properties›

locale ab_group_add_ow =
  minus_ow U minus + uminus_ow U uminus + comm_monoid_add_ow U plus zero
  for U :: "'ag set" and plus zero minus uminus +
  assumes ab_left_minus: "a  U  -ow a +ow a = 0ow"
  assumes ab_diff_conv_add_uminus: 
    " a  U; b  U   a -ow b = a +ow (-ow b)"
begin

sublocale group_add_ow 
  by unfold_locales (simp_all add: ab_left_minus ab_diff_conv_add_uminus)

sublocale cancel_comm_monoid_add_ow 
  apply unfold_locales
  subgoal using add.commute by (fastforce simp: add_diff_cancel)
  subgoal by (metis add.commute diff_add_eq_diff_diff_swap)
  done

end

lemma ab_group_add_ow: "class.ab_group_add = ab_group_add_ow UNIV"
  unfolding 
  class.ab_group_add_def ab_group_add_ow_def
  class.ab_group_add_axioms_def ab_group_add_ow_axioms_def
  minus_ow_def uminus_ow_def
  comm_monoid_add_ow
  by simp

lemma ab_group_add_ow_UNIV_axioms: 
  "ab_group_add_ow (UNIV::'a::ab_group_add set) (+) 0 (-) uminus"
  by (fold ab_group_add_ow) (rule ab_group_add_class.ab_group_add_axioms)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma ab_group_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (A ===> A) ===> (=))
      (ab_group_add_ow (Collect (Domainp A))) class.ab_group_add"
proof -
  let ?P = 
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (A ===> A) ===> (=))"
  let ?ab_group_add_ow = "ab_group_add_ow (Collect (Domainp A))"
  have 
    "?P 
      ?ab_group_add_ow 
      (
        λplus zero minus uminus. 
          (xUNIV. yUNIV. minus x y  UNIV) 
          (xUNIV. uminus x  UNIV)   
          class.ab_group_add plus zero minus uminus
      )"
    unfolding 
      ab_group_add_ow_def class.ab_group_add_def
      ab_group_add_ow_axioms_def class.ab_group_add_axioms_def
      minus_ow_def uminus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

end


subsubsection‹Relativization›

context ab_group_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ab_group_add_ow_axioms and zero.not_empty
  applying [OF plus_closed' zero_closed minus_closed' add.inverse_closed'']
begin

tts_lemma uminus_add_conv_diff:
  assumes "a  U" and "b  U"
  shows "-ow a +ow b = b -ow a"
    is ab_group_add_class.uminus_add_conv_diff.
    
tts_lemma diff_add_eq:
  assumes "a  U" and "b  U" and "c  U"
  shows "a -ow b +ow c = a +ow c -ow b"
    is ab_group_add_class.diff_add_eq.

end

end

text‹\newpage›

end

Theory SML_Semirings

(* Title: Examples/SML_Relativization/Algebra/SML_Semirings.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about semirings›
theory SML_Semirings
  imports SML_Groups
begin



subsection‹Semirings›


subsubsection‹Definitions and common properties›

locale semiring_ow =
  ab_semigroup_add_ow U plus + semigroup_mult_ow U times 
  for U :: "'ag set" and plus times +
  assumes distrib_right[simp]: 
    " a  U; b  U; c  U   (a +ow b) *ow c = a *ow c +ow b *ow c"
  assumes distrib_left[simp]: 
    " a  U; b  U; c  U   a *ow (b +ow c) = a *ow b +ow a *ow c"

lemma semiring_ow: "class.semiring = semiring_ow UNIV"
  unfolding 
    class.semiring_def semiring_ow_def
    class.semiring_axioms_def semiring_ow_axioms_def
    ab_semigroup_add_ow semigroup_mult_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semiring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=)) 
      (semiring_ow (Collect (Domainp A))) class.semiring"
  unfolding 
    semiring_ow_def class.semiring_def
    semiring_ow_axioms_def class.semiring_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end


subsubsection‹Relativization›

context semiring_ow
begin

tts_context
  tts: (?'a to U)
  substituting semiring_ow_axioms
  eliminating through simp
begin

tts_lemma combine_common_factor:
  assumes "a  U" and "e  U" and "b  U" and "c  U"
  shows "a *ow e +ow (b *ow e +ow c) = (a +ow b) *ow e +ow c"
    is semiring_class.combine_common_factor.

end

end



subsection‹Commutative semirings›


subsubsection‹Definitions and common properties›

locale comm_semiring_ow = 
  ab_semigroup_add_ow U plus + ab_semigroup_mult_ow U times
  for U :: "'ag set" and plus times +
  assumes distrib: 
    "a  U; b  U; c  U  (a +ow b) *ow c = a *ow c +ow b *ow c"
begin

sublocale semiring_ow
proof
  fix a b c :: 'ag
  assume "a  U" and "b  U" and "c  U"
  then show "(a +ow b) *ow c = a *ow c +ow b *ow c" by (simp only: distrib)
  show "a *ow (b +ow c) = a *ow b +ow a *ow c"
  proof-
    from a  U b  U c  U have "a *ow (b +ow c) = (b +ow c) *ow a" 
      by (simp add: mult_commute)
    with a  U b  U c  U have "a *ow (b +ow c) = b *ow a +ow c *ow a" 
      by (simp only: distrib)
    with a  U b  U c  U show ?thesis  by (simp only: mult_commute)
  qed
qed

end

lemma comm_semiring_ow: "class.comm_semiring = comm_semiring_ow UNIV"
  unfolding 
    class.comm_semiring_def comm_semiring_ow_def
    class.comm_semiring_axioms_def comm_semiring_ow_axioms_def
    ab_semigroup_add_ow ab_semigroup_mult_ow
  by simp


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma comm_semiring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=)) 
      (comm_semiring_ow (Collect (Domainp A))) class.comm_semiring"
    (is "?PR (comm_semiring_ow (Collect (Domainp A))) class.comm_semiring")
  unfolding 
    comm_semiring_ow_def class.comm_semiring_def
    comm_semiring_ow_axioms_def class.comm_semiring_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end



subsection‹Semirings with zero›


subsubsection‹Definitions and further results›

locale mult_zero_ow = times_ow U times + zero_ow U zero
  for U :: "'ag set" and times zero +
  assumes mult_zero_left[simp]: "a  U  0ow *ow a = 0ow"
  assumes mult_zero_right[simp]: "a  U  a *ow 0ow = 0ow"

lemma mult_zero_ow: "class.mult_zero = mult_zero_ow UNIV"
  unfolding 
    class.mult_zero_def mult_zero_ow_def mult_zero_ow_axioms_def
    times_ow_def zero_ow_def neutral_ow_def
  by simp

locale semiring_0_ow = 
  semiring_ow U plus times + 
  comm_monoid_add_ow U plus zero + 
  mult_zero_ow U times zero
  for U :: "'ag set" and plus zero times 

lemma semiring_0_ow: "class.semiring_0 = semiring_0_ow UNIV"
  unfolding 
    class.semiring_0_def semiring_0_ow_def  
    mult_zero_ow comm_monoid_add_ow semiring_ow
  by (auto simp: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semiring_0_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (=)) 
      (semiring_0_ow (Collect (Domainp A))) class.semiring_0"
    (is "?PR (semiring_0_ow (Collect (Domainp A))) class.semiring_0")
proof-
  let ?semiring_0 =
    "(
      λplus zero times. 
        class.semiring_0 plus zero times 
        (a b. a  UNIV  b  UNIV  times a b  UNIV)  zero  UNIV
    )" 
  have "?PR (semiring_0_ow (Collect (Domainp A))) ?semiring_0" 
    unfolding
      semiring_0_ow_def  class.semiring_0_def
      mult_zero_ow_def class.mult_zero_def
      mult_zero_ow_axioms_def
      times_ow_def zero_ow_def neutral_ow_def 
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

end



subsection‹Commutative semirings with zero›


subsubsection‹Definitions and common properties›

locale comm_semiring_0_ow = 
  comm_semiring_ow U plus times +  
  comm_monoid_add_ow U plus zero + 
  mult_zero_ow U times zero
  for U :: "'ag set" and plus zero times 
begin

sublocale semiring_0_ow by unfold_locales

end

lemma comm_semiring_0_ow: "class.comm_semiring_0 = comm_semiring_0_ow UNIV"
  unfolding 
    class.comm_semiring_0_def comm_semiring_0_ow_def
    comm_monoid_add_ow comm_semiring_ow mult_zero_ow
  by (auto simp: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma comm_semiring_0_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (=)) 
      (comm_semiring_0_ow (Collect (Domainp A))) class.comm_semiring_0"
    (is "?PR (comm_semiring_0_ow (Collect (Domainp A))) class.comm_semiring_0")
proof-
  let ?comm_semiring_0 =
    "(
      λplus zero times. 
        class.comm_semiring_0 plus zero times 
        (a b. a  UNIV  b  UNIV  times a b  UNIV)  zero  UNIV
    )" 
  have "?PR (comm_semiring_0_ow (Collect (Domainp A))) ?comm_semiring_0" 
    unfolding
      comm_semiring_0_ow_def class.comm_semiring_0_def
      mult_zero_ow_def class.mult_zero_def
      mult_zero_ow_axioms_def
      times_ow_def zero_ow_def neutral_ow_def 
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

end



subsection‹Cancellative semirings with zero›


subsubsection‹Definitions and common properties›

locale semiring_0_cancel_ow =
  semiring_ow U plus times + cancel_comm_monoid_add_ow U plus minus zero
  for U :: "'ag set" and plus minus zero times
begin

sublocale semiring_0_ow 
proof
  fix a
  show "a  U  0ow *ow a = 0ow"
  proof-
    assume "a  U"
    have "0ow *ow a  U" by (simp add: a  U times_closed') 
    have "0ow *ow a +ow 0ow *ow a = 0ow *ow a +ow 0ow" 
      by (simp add: a  U 0ow *ow a  U distrib_right[symmetric])
    then show ?thesis 
      unfolding add_left_cancel[OF 0ow *ow a  U 0ow *ow a  U zero_closed]
      by assumption
  qed
  show "a  U  a *ow 0ow = 0ow"
  proof-
    assume "a  U"
    have "a *ow 0ow  U" by (simp add: a  U times_closed')
    have "a *ow 0ow +ow a *ow 0ow = a *ow 0ow +ow 0ow"
      by (simp add: a  U a *ow 0ow  U distrib_left[symmetric])
    then show ?thesis
      unfolding add_left_cancel[OF a *ow 0ow  U a *ow 0ow  U zero_closed]
      by assumption
  qed
qed

end

lemma semiring_0_cancel_ow: 
  "class.semiring_0_cancel = semiring_0_cancel_ow UNIV"
  unfolding 
    class.semiring_0_cancel_def 
    semiring_0_cancel_ow_def
    cancel_comm_monoid_add_ow semiring_ow
  by (simp add: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semiring_0_cancel_transfer[transfer_rule]: 
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      (A ===> A ===> A) ===> 
      (=)
    ) (semiring_0_cancel_ow (Collect (Domainp A))) class.semiring_0_cancel"
  unfolding semiring_0_cancel_ow_def class.semiring_0_cancel_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end



subsection‹Commutative cancellative semirings with zero›


subsubsection‹Definitions and common properties›

locale comm_semiring_0_cancel_ow = 
  comm_semiring_ow U plus times + 
  cancel_comm_monoid_add_ow U plus minus zero
  for U :: "'ag set" and plus  minus zero times 
begin

sublocale semiring_0_cancel_ow by unfold_locales

sublocale comm_semiring_0_ow by unfold_locales

end

lemma comm_semiring_0_cancel_ow: 
  "class.comm_semiring_0_cancel = comm_semiring_0_cancel_ow UNIV"
  unfolding 
    class.comm_semiring_0_cancel_def comm_semiring_0_cancel_ow_def
    cancel_comm_monoid_add_ow comm_semiring_ow
  by (simp add: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma comm_semiring_0_cancel_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      (A ===> A ===> A) ===> 
      (=)
    ) 
    (comm_semiring_0_cancel_ow (Collect (Domainp A))) 
    class.comm_semiring_0_cancel"
  unfolding comm_semiring_0_cancel_ow_def class.comm_semiring_0_cancel_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end



subsection‹Class class‹zero_neq_one›


subsubsection‹Definitions and common properties›

locale zero_neq_one_ow = 
  zero_ow U zero + one_ow U one
  for U :: "'ag set" and one (1ow) and zero (0ow)  +
  assumes zero_neq_one[simp]: "0ow  1ow"

lemma zero_neq_one_ow: "class.zero_neq_one = zero_neq_one_ow UNIV"
  unfolding 
    class.zero_neq_one_def zero_neq_one_ow_def
    zero_neq_one_ow_axioms_def
    one_ow_def zero_ow_def neutral_ow_def
  by simp

ud ‹zero_neq_one.of_bool› ((with _ _ : «of'_bool» _) [1000, 999, 1000] 10)
ud of_bool' ‹of_bool›

ctr parametricity
  in of_bool.with_def

context zero_neq_one_ow
begin

abbreviation of_bool where "of_bool  of_bool.with 1ow 0ow"

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma zero_neq_one_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"  
  shows 
    "(A ===> A ===> (=)) 
      (zero_neq_one_ow (Collect (Domainp A))) class.zero_neq_one" 
    (is "?PR (zero_neq_one_ow (Collect (Domainp A))) class.zero_neq_one")
proof-
  let ?zero_neq_one = 
    "(λone zero. class.zero_neq_one one zero  one  UNIV  zero  UNIV)"
  have "?PR (zero_neq_one_ow (Collect (Domainp A))) ?zero_neq_one"
    unfolding 
      zero_neq_one_ow_def class.zero_neq_one_def
      zero_neq_one_ow_axioms_def
      zero_ow_def one_ow_def neutral_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

end


subsubsection‹Relativization›

context zero_neq_one_ow
begin

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting zero_neq_one_ow_axioms
  eliminating through simp
begin

tts_lemma split_of_bool_asm:
  shows "P (of_bool p) = (¬ (p  ¬ P 1ow  ¬ p  ¬ P 0ow))"
    is zero_neq_one_class.split_of_bool_asm.
    
tts_lemma of_bool_eq_iff:
  shows "(of_bool p = local.of_bool q) = (p = q)"
    is zero_neq_one_class.of_bool_eq_iff.
    
tts_lemma split_of_bool:
  shows "P (of_bool p) = ((p  P 1ow)  (¬ p  P 0ow))"
    is zero_neq_one_class.split_of_bool.

tts_lemma one_neq_zero: "1ow  0ow"
  is zero_neq_one_class.one_neq_zero.
    
tts_lemma of_bool_eq:
  shows "of_bool False = 0ow" 
    is zero_neq_one_class.of_bool_eq(1)
    and "of_bool True = 1ow"
    is zero_neq_one_class.of_bool_eq(2).

end

end



subsection‹Semirings with zero and one (rigs)›


subsubsection‹Definitions and commmon properties›

locale semiring_1_ow =
  zero_neq_one_ow U one zero +
  semiring_0_ow U plus zero times + 
  monoid_mult_ow U one times
  for U :: "'ag set" and one times plus zero

lemma semiring_1_ow: "class.semiring_1 = semiring_1_ow UNIV"
  unfolding 
    class.semiring_1_def semiring_1_ow_def
    monoid_mult_ow semiring_0_ow zero_neq_one_ow
  by (auto simp: conj_commute)

ud ‹semiring_1.of_nat› ((with _ _ _ : «of'_nat» _) [1000, 999, 998, 1000] 10)
ud of_nat' ‹of_nat›

ud ‹semiring_1.Nats› ((with _ _ _ : ) [1000, 999, 998] 10)
ud Nats' ‹Nats›

ctr parametricity
  in of_nat_ow: of_nat.with_def
    and Nats_ow: Nats.with_def

context semiring_1_ow
begin

abbreviation of_nat where "of_nat  of_nat.with 1ow (+ow) 0ow"
abbreviation Nats («ℕ») where "«ℕ»  Nats.with 1ow (+ow) 0ow"
notation Nats («ℕ»)

end

context semiring_1
begin

lemma Nat_ss_UNIV: "  UNIV" by simp

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semiring_1_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(A ===> (A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (=)) 
      (semiring_1_ow (Collect (Domainp A))) class.semiring_1"
  unfolding semiring_1_ow_def class.semiring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end


subsubsection‹Relativization›

context semiring_1_ow
begin

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting semiring_1_ow_axioms and zero.not_empty 
  eliminating through simp
begin

tts_lemma Nat_ss_UNIV[simp]:
  shows "«ℕ»  U"
    is Nat_ss_UNIV.

end

lemma Nat_closed[simp, intro]: "a  «ℕ»  a  U" using Nat_ss_UNIV by blast

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting semiring_1_ow_axioms and zero.not_empty
  eliminating through auto
begin

tts_lemma mult_of_nat_commute:
  assumes "y  U"
  shows "of_nat x *ow y = y *ow of_nat x"
    is semiring_1_class.mult_of_nat_commute.

tts_lemma of_bool_conj: "of_bool (P  Q) = of_bool P *ow of_bool Q"
  is semiring_1_class.of_bool_conj.

tts_lemma power_0_left: "0ow ^ow n = (if n = 0 then 1ow else 0ow)"
  is semiring_1_class.power_0_left.

tts_lemma of_nat_power: "of_nat ((with 1 (*) : m ^ow n)) = of_nat m ^ow n"
  is semiring_1_class.of_nat_power.

tts_lemma of_nat_of_bool: "of_nat (with 1 0 : «of_bool» P) = of_bool P"
  is semiring_1_class.of_nat_of_bool.

tts_lemma of_nat_in_Nats: "of_nat n  «ℕ»"
  is semiring_1_class.of_nat_in_Nats.

tts_lemma zero_power2: "0ow ^ow 2 = 0ow"
  is semiring_1_class.zero_power2.

tts_lemma power_0_Suc: "0ow ^ow Suc n = 0ow"
  is semiring_1_class.power_0_Suc.

tts_lemma zero_power:
  assumes "0 < n"
  shows "0ow ^ow n = 0ow"
    is semiring_1_class.zero_power.

tts_lemma one_power2: "1ow ^ow 2 = 1ow"
  is semiring_1_class.one_power2.

tts_lemma of_nat_simps:
  shows "of_nat 0 = 0ow" 
    is semiring_1_class.of_nat_simps(1)
    and "of_nat (Suc m) = 1ow +ow of_nat m"
    is semiring_1_class.of_nat_simps(2).

tts_lemma of_nat_mult: "of_nat (m * n) = of_nat m *ow of_nat n"
  is semiring_1_class.of_nat_mult.

tts_lemma Nats_induct:
  assumes "x  «ℕ»" and "n. P (of_nat n)"
  shows "P x"
    is semiring_1_class.Nats_induct.

tts_lemma of_nat_add: "of_nat (m + n) = of_nat m +ow of_nat n"
  is semiring_1_class.of_nat_add.

tts_lemma of_nat_Suc: "of_nat (Suc m) = 1ow +ow of_nat m"
  is semiring_1_class.of_nat_Suc.

tts_lemma Nats_cases:
  assumes "x  «ℕ»" 
  obtains (of_nat) n where "x = of_nat n"
    given semiring_1_class.Nats_cases by auto

tts_lemma Nats_mult:
  assumes "a  «ℕ»" and "b  «ℕ»"
  shows "a *ow b  «ℕ»"
    is semiring_1_class.Nats_mult.

tts_lemma of_nat_1: "of_nat 1 = 1ow"
  is semiring_1_class.of_nat_1.

tts_lemma of_nat_0: "of_nat 0 = 0ow"
  is semiring_1_class.of_nat_0.

tts_lemma Nats_add:
  assumes "a  «ℕ»" and "b  «ℕ»"
  shows "a +ow b  «ℕ»"
    is semiring_1_class.Nats_add.

tts_lemma Nats_1: "1ow  «ℕ»"
  is semiring_1_class.Nats_1.

tts_lemma Nats_0: "0ow  «ℕ»"
  is semiring_1_class.Nats_0.

end

end



subsection‹Commutative rigs›


subsubsection‹Definitions and common properties›

locale comm_semiring_1_ow = 
  zero_neq_one_ow U one zero +
  comm_semiring_0_ow U plus zero times +
  comm_monoid_mult_ow U times one
  for U :: "'ag set" and times one plus zero  
begin

sublocale semiring_1_ow by unfold_locales

end

lemma comm_semiring_1_ow: "class.comm_semiring_1 = comm_semiring_1_ow UNIV"
  unfolding 
    class.comm_semiring_1_def comm_semiring_1_ow_def
    comm_monoid_mult_ow comm_semiring_0_ow zero_neq_one_ow
  by (auto simp: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma comm_semiring_1_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> A ===> (=)) 
      (comm_semiring_1_ow (Collect (Domainp A))) class.comm_semiring_1"
  unfolding comm_semiring_1_ow_def class.comm_semiring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end


subsubsection‹Relativization›

context comm_semiring_1_ow
begin

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting comm_semiring_1_ow_axioms and zero.not_empty
  applying [OF times_closed' one_closed plus_closed' zero_closed]
begin

tts_lemma semiring_normalization_rules:
  shows 
    "a  U; m  U; b  U  a *ow m +ow b *ow m = (a +ow b) *ow m"
    "a  U; m  U  a *ow m +ow m = (a +ow 1ow) *ow m"
    "m  U; a  U  m +ow a *ow m = (a +ow 1ow) *ow m"
    "m  U  m +ow m = (1ow +ow 1ow) *ow m"
    "a  U  0ow +ow a = a"
    "a  U  a +ow 0ow = a"
    "a  U; b  U  a *ow b = b *ow a"
    "a  U; b  U; c  U  (a +ow b) *ow c = a *ow c +ow b *ow c"
    "a  U  0ow *ow a = 0ow"
    "a  U  a *ow 0ow = 0ow"
    "a  U  1ow *ow a = a"
    "a  U  a *ow 1ow = a"
    "lx  U; ly  U; rx  U; ry  U  
      lx *ow ly *ow (rx *ow ry) = lx *ow rx *ow (ly *ow ry)"
    "lx  U; ly  U; rx  U; ry  U  
      lx *ow ly *ow (rx *ow ry) = lx *ow (ly *ow (rx *ow ry))"
    "lx  U; ly  U; rx  U; ry  U  
      lx *ow ly *ow (rx *ow ry) = rx *ow (lx *ow ly *ow ry)"
    "lx  U; ly  U; rx  U  lx *ow ly *ow rx = lx *ow rx *ow ly"
    "lx  U; ly  U; rx  U  lx *ow ly *ow rx = lx *ow (ly *ow rx)"
    "lx  U; rx  U; ry  U  lx *ow (rx *ow ry) = lx *ow rx *ow ry"
    "lx  U; rx  U; ry  U  lx *ow (rx *ow ry) = rx *ow (lx *ow ry)"
    "a  U; b  U; c  U; d  U  
      a +ow b +ow (c +ow d) = a +ow c +ow (b +ow d)"
    "a  U; b  U; c  U  a +ow b +ow c = a +ow (b +ow c)"
    "a  U; c  U; d  U  a +ow (c +ow d) = c +ow (a +ow d)"
    "a  U; b  U; c  U  a +ow b +ow c = a +ow c +ow b"
    "a  U; c  U  a +ow c = c +ow a"
    "a  U; c  U; d  U  a +ow (c +ow d) = a +ow c +ow d"
    "x  U  x ^ow p *ow x ^ow q = x ^ow (p + q)"
    "x  U  x *ow x ^ow q = x ^ow Suc q"
    "x  U  x ^ow q *ow x = x ^ow Suc q"
    "x  U  x *ow x = x ^ow 2"
    "x  U; y  U  (x *ow y) ^ow q = x ^ow q *ow y ^ow q"
    "x  U  (x ^ow p) ^ow q = x ^ow (p * q)"
    "x  U  x ^ow 0 = 1ow"
    "x  U  x ^ow 1 = x"
    "x  U; y  U; z  U  x *ow (y +ow z) = x *ow y +ow x *ow z"
    "x  U  x ^ow Suc q = x *ow x ^ow q"
    "x  U  x ^ow (2 * n) = x ^ow n *ow x ^ow n"
    is comm_semiring_1_class.semiring_normalization_rules.

tts_lemma le_imp_power_dvd:
  assumes "a  U" and "m  n"
  shows "a ^ow m «dvd» a ^ow n"
    is comm_semiring_1_class.le_imp_power_dvd.

tts_lemma dvd_0_left_iff:
  assumes "a  U"
  shows "(0ow «dvd» a) = (a = 0ow)"
    is comm_semiring_1_class.dvd_0_left_iff.

tts_lemma dvd_power_same:
  assumes "x  U" and "y  U" and "x «dvd» y"
  shows "x ^ow n «dvd» y ^ow n"
    is comm_semiring_1_class.dvd_power_same.

tts_lemma power_le_dvd:
  assumes "a  U" and "b  U" and "a ^ow n «dvd» b" and "m  n"
  shows "a ^ow m «dvd» b"
    is comm_semiring_1_class.power_le_dvd.

tts_lemma dvd_0_right:
  assumes "a  U"
  shows "a «dvd» 0ow"
    is comm_semiring_1_class.dvd_0_right.

tts_lemma dvd_0_left:
  assumes "a  U" and "0ow «dvd» a"
  shows "a = 0ow"
    is comm_semiring_1_class.dvd_0_left.

tts_lemma dvd_power:
  assumes "x  U" and "0 < n  x = 1ow"
  shows "x «dvd» x ^ow n"
    is comm_semiring_1_class.dvd_power.

tts_lemma dvd_add:
  assumes "a  U" and "b  U" and "c  U" and "a «dvd» b" and "a «dvd» c"
  shows "a «dvd» b +ow c"
    is comm_semiring_1_class.dvd_add.

end

end



subsection‹Cancellative rigs›


subsubsection‹Definitions and common properties›

locale semiring_1_cancel_ow =
  semiring_ow U plus times +
  cancel_comm_monoid_add_ow U plus minus zero +
  zero_neq_one_ow U one zero +
  monoid_mult_ow U one times
  for U :: "'ag set" and plus minus zero one times
begin

sublocale semiring_0_cancel_ow ..
sublocale semiring_1_ow ..

end

lemma semiring_1_cancel_ow: 
  "class.semiring_1_cancel = semiring_1_cancel_ow UNIV"
  unfolding 
    class.semiring_1_cancel_def semiring_1_cancel_ow_def
    cancel_comm_monoid_add_ow monoid_mult_ow semiring_ow zero_neq_one_ow
  by (force simp: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semiring_1_cancel_transfer[transfer_rule]:
  includes lifting_syntax
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      A ===> 
      (A ===> A ===> A) ===> 
      (=)
    ) (semiring_1_cancel_ow (Collect (Domainp A))) class.semiring_1_cancel"
  unfolding semiring_1_cancel_ow_def class.semiring_1_cancel_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end



subsection‹Commutative cancellative rigs›


subsubsection‹Definitions and common properties›

locale comm_semiring_1_cancel_ow =
  comm_semiring_ow U plus times + 
  cancel_comm_monoid_add_ow U plus minus zero + 
  zero_neq_one_ow U one zero +  
  comm_monoid_mult_ow U times one 
  for U :: "'ag set" and plus minus zero times one + 
  assumes right_diff_distrib'[algebra_simps]: 
    " a  U; b  U; c  U   a *ow (b -ow c) = a *ow b -ow a *ow c" 
begin

sublocale semiring_1_cancel_ow ..
sublocale comm_semiring_0_cancel_ow ..
sublocale comm_semiring_1_ow ..

end


subsubsection‹Transfer rules›

context 
  includes lifting_syntax
begin

lemma comm_semiring_1_cancel_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      (=)
    ) 
    (comm_semiring_1_cancel_ow (Collect (Domainp A))) 
    class.comm_semiring_1_cancel"
  unfolding 
    comm_semiring_1_cancel_ow_def class.comm_semiring_1_cancel_def
    comm_semiring_1_cancel_ow_axioms_def 
    class.comm_semiring_1_cancel_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end


subsubsection‹Relativization›

context comm_semiring_1_cancel_ow
begin

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting comm_semiring_1_cancel_ow_axioms and zero.not_empty
  applying [OF plus_closed' minus_closed' zero_closed times_closed' one_closed]
begin

tts_lemma dvd_add_times_triv_right_iff:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a «dvd» b +ow c *ow a) = (a «dvd» b)"
  is comm_semiring_1_cancel_class.dvd_add_times_triv_right_iff.

tts_lemma dvd_add_times_triv_left_iff:
  assumes "a  U" and "c  U" and "b  U"
  shows "(a «dvd» c *ow a +ow b) = (a «dvd» b)"
    is comm_semiring_1_cancel_class.dvd_add_times_triv_left_iff.

tts_lemma dvd_add_triv_right_iff:
  assumes "a  U" and "b  U"
  shows "(a «dvd» b +ow a) = (a «dvd» b)"
    is comm_semiring_1_cancel_class.dvd_add_triv_right_iff.

tts_lemma dvd_add_triv_left_iff:
  assumes "a  U" and "b  U"
  shows "(a «dvd» a +ow b) = (a «dvd» b)"
    is comm_semiring_1_cancel_class.dvd_add_triv_left_iff.

tts_lemma left_diff_distrib':
  assumes "b  U" and "c  U" and "a  U"
  shows "(b -ow c) *ow a = b *ow a -ow c *ow a"
    is comm_semiring_1_cancel_class.left_diff_distrib'.

tts_lemma dvd_add_right_iff:
  assumes "a  U" and "b  U" and "c  U" and "a «dvd» b"
  shows "(a «dvd» b +ow c) = (a «dvd» c)"
    is comm_semiring_1_cancel_class.dvd_add_right_iff.

tts_lemma dvd_add_left_iff:
  assumes "a  U" and "c  U" and "b  U" and "a «dvd» c"
  shows "(a «dvd» b +ow c) = (a «dvd» b)"
    is comm_semiring_1_cancel_class.dvd_add_left_iff.

end

end

text‹\newpage›

end

Theory SML_Rings

(* Title: Examples/SML_Relativization/Algebra/SML_Rings.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about rings›
theory SML_Rings
  imports 
    SML_Semirings
    Complex_Main
begin



subsection‹Rings›


subsubsection‹Definitions and common properties›

locale ring_ow =
  semiring_ow U plus times + ab_group_add_ow U plus zero minus uminus
  for U :: "'ag set" and plus zero minus uminus times
begin

sublocale semiring_0_cancel_ow ..

end

lemma ring_ow: "class.ring = ring_ow UNIV"
  unfolding class.ring_def ring_ow_def ab_group_add_ow semiring_ow
  by (simp add: conj_commute)

lemma ring_ow_UNIV_axioms: "ring_ow (UNIV::'a::ring set) (+) 0 (-) uminus (*)"
  by (fold ring_ow) (rule ring_class.ring_axioms)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma ring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      A ===> 
      (A ===> A ===> A) ===> 
      (A ===> A) ===> 
      (A ===> A ===> A) ===> 
      (=)
    ) 
    (ring_ow (Collect (Domainp A))) class.ring"
  unfolding ring_ow_def class.ring_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end


subsubsection‹Relativization›

context ring_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ring_ow_axioms and zero.not_empty
  applying 
    [
      OF 
        plus_closed' 
        zero_closed 
        minus_closed' 
        add.inverse_closed'' 
        times_closed'
    ] 
begin

tts_lemma right_diff_distrib:
  assumes "a  U" and "b  U" and "c  U"
  shows "a *ow (b -ow c) = a *ow b -ow a *ow c"
    is Rings.ring_class.right_diff_distrib.

tts_lemma minus_mult_commute:
  assumes "a  U" and "b  U"
  shows "-ow a *ow b = a *ow -ow b"
    is Rings.ring_class.minus_mult_commute.

tts_lemma left_diff_distrib:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a -ow b) *ow c = a *ow c -ow b *ow c"
    is Rings.ring_class.left_diff_distrib.

tts_lemma mult_minus_right:
  assumes "a  U" and "b  U"
  shows "a *ow -ow b = -ow (a *ow b)"
    is Rings.ring_class.mult_minus_right.

tts_lemma minus_mult_right:
  assumes "a  U" and "b  U"
  shows "-ow (a *ow b) = a *ow -ow b"
    is Rings.ring_class.minus_mult_right.

tts_lemma minus_mult_minus:
  assumes "a  U" and "b  U"
  shows "-ow a *ow -ow b = a *ow b"
    is Rings.ring_class.minus_mult_minus.

tts_lemma mult_minus_left:
  assumes "a  U" and "b  U"
  shows "-ow a *ow b = -ow (a *ow b)"
    is Rings.ring_class.mult_minus_left.

tts_lemma minus_mult_left:
  assumes "a  U" and "b  U"
  shows "-ow (a *ow b) = -ow a *ow b"
    is Rings.ring_class.minus_mult_left.

tts_lemma ring_distribs:
  assumes "a  U" and "b  U" and "c  U"
  shows 
    "a *ow (b +ow c) = a *ow b +ow a *ow c"
    "(a +ow b) *ow c = a *ow c +ow b *ow c"
    "(a -ow b) *ow c = a *ow c -ow b *ow c"
    "a *ow (b -ow c) = a *ow b -ow a *ow c"
    is Rings.ring_class.ring_distribs.

tts_lemma eq_add_iff2:
  assumes "a  U" and "e  U" and "c  U" and "b  U" and "d  U"
  shows "(a *ow e +ow c = b *ow e +ow d) = (c = (b -ow a) *ow e +ow d)"
    is Rings.ring_class.eq_add_iff2.

tts_lemma eq_add_iff1:
  assumes "a  U" and "e  U" and "c  U" and "b  U" and "d  U"
  shows "(a *ow e +ow c = b *ow e +ow d) = ((a -ow b) *ow e +ow c = d)"
    is Rings.ring_class.eq_add_iff1.

tts_lemma mult_diff_mult:
  assumes "x  U" and "y  U" and "a  U" and "b  U"
  shows "x *ow y -ow a *ow b = x *ow (y -ow b) +ow (x -ow a) *ow b"
    is Real.mult_diff_mult.

end

end



subsection‹Commutative rings›


subsubsection‹Definitions and common properties›

locale comm_ring_ow =
  comm_semiring_ow U plus times + ab_group_add_ow U plus zero minus uminus
  for U :: "'ag set" and plus zero minus uminus times
begin

sublocale ring_ow ..
sublocale comm_semiring_0_cancel_ow ..

end

lemma comm_ring_ow: "class.comm_ring = comm_ring_ow UNIV"
  unfolding 
    class.comm_ring_def comm_ring_ow_def 
    ab_group_add_ow comm_semiring_ow
  by (simp add: conj_commute)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma comm_ring_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      A ===> 
      (A ===> A ===> A) ===> 
      (A ===> A) ===>
      (A ===> A ===> A) ===>
      (=)
    ) 
    (comm_ring_ow (Collect (Domainp A))) class.comm_ring"
  unfolding comm_ring_ow_def class.comm_ring_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end


subsubsection‹Relativization›

context comm_ring_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_ring_ow_axioms and zero.not_empty
  applying 
    [
      OF 
        plus_closed' 
        zero_closed 
        minus_closed' 
        add.inverse_closed'' 
        times_closed'
    ] 
begin

tts_lemma square_diff_square_factored:
  assumes "x  U" and "y  U"
  shows "x *ow x -ow y *ow y = (x +ow y) *ow (x -ow y)"
    is comm_ring_class.square_diff_square_factored.

end

end



subsection‹Rings with identity›


subsubsection‹Definitions and common properties›

locale ring_1_ow =
  ring_ow U plus zero minus uminus times + 
  zero_neq_one_ow U one zero + 
  monoid_mult_ow U one times 
  for U :: "'ag set" and one times plus zero minus uminus
begin

sublocale semiring_1_cancel_ow ..

end

lemma ring_1_ow: "class.ring_1 = ring_1_ow UNIV"
  unfolding 
    class.ring_1_def ring_1_ow_def monoid_mult_ow ring_ow zero_neq_one_ow
  by (force simp: conj_commute)

lemma ring_1_ow_UNIV_axioms: 
  "ring_1_ow (UNIV::'a::ring_1 set) 1 (*) (+) 0 (-) uminus"
  by (fold ring_1_ow) (rule ring_1_class.ring_1_axioms)

ud ‹ring_1.iszero› ((with _ : «iszero» _) [1000, 1000] 10)
ud iszero' ‹iszero› 
ud ‹ring_1.of_int›
  ((with _ _ _ _ : «of'_int» _) [1000, 999, 998, 997, 1000] 10)
ud of_int' ‹of_int›
ud ‹ring_1.Ints› ((with _ _ _ _ : ) [1000, 999, 998, 997] 10)
ud Ints' ‹Ints›
ud ‹diffs› ((with _ _ _ _ : «diffs» _) [1000, 999, 998, 997, 1000] 10)

ctr parametricity  
  in iszero_ow: iszero.with_def 
    and of_int_ow: of_int.with_def
    and Ints_ow: Ints.with_def
    and diffs_ow: diffs.with_def

context ring_1_ow
begin

abbreviation iszero where "iszero  iszero.with 0ow"
abbreviation of_int where "of_int  of_int.with 1ow (+ow) 0ow (-ow)"
abbreviation Ints («ℤ») where "«ℤ»  Ints.with 1ow (+ow) 0ow (-ow)"
notation Ints («ℤ»)

end

context ring_1
begin

lemma Int_ss_UNIV: "  UNIV" by simp 

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma ring_1_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      A ===> 
      (A ===> A ===> A) ===>
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===> 
      (A ===> A) ===>
      (=)
    ) 
      (ring_1_ow (Collect (Domainp A))) class.ring_1"
  unfolding ring_1_ow_def class.ring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end


subsubsection‹Relativization›

declare dvd.with[ud_with del]
declare dvd'.with[ud_with del]

context ring_1_ow
begin

tts_context
  tts: (?'a to U)
  substituting ring_1_ow_axioms and zero.not_empty
  eliminating through simp
begin

tts_lemma Int_ss_UNIV[simp]: "«ℤ»  U"
  is Int_ss_UNIV.

end

lemma Int_closed[simp,intro]: "a  «ℤ»  a  U" using Int_ss_UNIV by blast

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ring_1_ow_axioms and zero.not_empty
  eliminating through auto
begin

tts_lemma iszero_0: "iszero 0ow"
  is ring_1_class.iszero_0.
    
tts_lemma not_iszero_1: "¬ iszero 1ow"
  is ring_1_class.not_iszero_1.

tts_lemma Nats_subset_Ints: "«ℕ»  «ℤ»"
  is Int.ring_1_class.Nats_subset_Ints.

tts_lemma Ints_1: "1ow  «ℤ»"
  is Int.ring_1_class.Ints_1.

tts_lemma Ints_0: "0ow  «ℤ»"
  is Int.ring_1_class.Ints_0.

tts_lemma not_iszero_neg_1: "¬ iszero (-ow 1ow)"
  is Num.ring_1_class.not_iszero_neg_1.

tts_lemma of_int_1: "of_int 1 = 1ow"
  is Int.ring_1_class.of_int_1.

tts_lemma of_int_0: "of_int 0 = 0ow"
  is Int.ring_1_class.of_int_0.

tts_lemma Ints_of_int: "of_int z  «ℤ»"
  is Int.ring_1_class.Ints_of_int.

tts_lemma Ints_of_nat: "of_nat n  «ℤ»"
  is Int.ring_1_class.Ints_of_nat.

tts_lemma of_int_of_nat_eq:
  shows "local.of_int (with 1 (+) 0 : «of_nat» n) = local.of_nat n"
    is Int.ring_1_class.of_int_of_nat_eq.

tts_lemma of_int_of_bool:
  "of_int (with 1 0 : «of_bool» P) = of_bool P"
  is Int.ring_1_class.of_int_of_bool.

tts_lemma of_int_minus: "of_int (- z) = -ow of_int z"
  is Int.ring_1_class.of_int_minus.

tts_lemma mult_minus1_right:
  assumes "z  U"
  shows "z *ow -ow 1ow = -ow z"
    is Num.ring_1_class.mult_minus1_right.

tts_lemma mult_minus1:
  assumes "z  U"
  shows "-ow 1ow *ow z = -ow z"
    is Num.ring_1_class.mult_minus1.

tts_lemma eq_iff_iszero_diff:
  assumes "x  U" and "y  U"
  shows "(x = y) = iszero (x -ow y)"
    is Num.ring_1_class.eq_iff_iszero_diff.

tts_lemma minus_in_Ints_iff:
  assumes "x  U"
  shows "(-ow x  «ℤ») = (x  «ℤ»)"
    is Int.ring_1_class.minus_in_Ints_iff.

tts_lemma mult_of_int_commute:
  assumes "y  U"
  shows "of_int x *ow y = y *ow of_int x"
    is Int.ring_1_class.mult_of_int_commute.

tts_lemma of_int_power:
  "of_int ((with 1 (*) : z ^ow n)) = of_int z ^ow n"
    is Int.ring_1_class.of_int_power.

tts_lemma Ints_minus:
  assumes "a  «ℤ»"
  shows "-ow a  «ℤ»"
    is Int.ring_1_class.Ints_minus.

tts_lemma of_int_diff: "of_int (w - z) = of_int w -ow of_int z"
  is Int.ring_1_class.of_int_diff.

tts_lemma of_int_add: "of_int (w + z) = of_int w +ow of_int z"
  is Int.ring_1_class.of_int_add.

tts_lemma of_int_mult: "of_int (w * z) = of_int w *ow of_int z"
  is Int.ring_1_class.of_int_mult.

tts_lemma power_minus1_even: "(-ow 1ow) ^ow (2 * n) = 1ow"
  is Power.ring_1_class.power_minus1_even.

tts_lemma Ints_power:
  assumes "a  «ℤ»"
  shows "a ^ow n  «ℤ»"
    is Int.ring_1_class.Ints_power.

tts_lemma of_nat_nat:
  assumes "0  z"
  shows "of_nat (nat z) = of_int z"
    is Int.ring_1_class.of_nat_nat.

tts_lemma power2_minus:
  assumes "a  U"
  shows "(-ow a) ^ow 2 = a ^ow 2"
    is Power.ring_1_class.power2_minus.

tts_lemma power_minus1_odd:
  shows "(-ow 1ow) ^ow Suc (2 * n) = -ow 1ow"
    is Power.ring_1_class.power_minus1_odd.

tts_lemma power_minus:
  assumes "a  U"
  shows "(-ow a) ^ow n = (-ow 1ow) ^ow n *ow a ^ow n"
    is Power.ring_1_class.power_minus.

tts_lemma square_diff_one_factored:
  assumes "x  U"
  shows "x *ow x -ow 1ow = (x +ow 1ow) *ow (x -ow 1ow)"
    is Rings.ring_1_class.square_diff_one_factored.

tts_lemma neg_one_even_power:
  assumes "even n"
  shows "(-ow 1ow) ^ow n = 1ow"
    is Parity.ring_1_class.neg_one_even_power.

tts_lemma minus_one_power_iff:
  "(-ow 1ow) ^ow n = (if even n then 1ow else -ow 1ow)"
    is Parity.ring_1_class.minus_one_power_iff.

tts_lemma Nats_altdef1: "«ℕ» = {x  U. y0. x = of_int y}"
    is Int.ring_1_class.Nats_altdef1.

tts_lemma Ints_induct:
  assumes "q  «ℤ»" and "z. P (of_int z)"
  shows "P q"
    is Int.ring_1_class.Ints_induct.

tts_lemma of_int_of_nat:
  shows 
    "of_int k = (if k < 0 then -ow of_nat (nat (- k)) else of_nat (nat k))"
    is Int.ring_1_class.of_int_of_nat.

tts_lemma Ints_diff:
  assumes "a  «ℤ»" and "b  «ℤ»"
  shows "a -ow b  «ℤ»"
    is Int.ring_1_class.Ints_diff.

tts_lemma Ints_add:
  assumes "a  «ℤ»" and "b  «ℤ»"
  shows "a +ow b  «ℤ»"
    is Int.ring_1_class.Ints_add.

tts_lemma Ints_mult:
  assumes "a  «ℤ»" and "b  «ℤ»"
  shows "a *ow b  «ℤ»"
    is Int.ring_1_class.Ints_mult.

tts_lemma power_minus_even':
  assumes "a  U" and "even n"
  shows "(-ow a) ^ow n = a ^ow n"
    is Parity.ring_1_class.power_minus_even.

tts_lemma power_minus_even:
  assumes "a  U"
  shows "(-ow a) ^ow (2 * n) = a ^ow (2 * n)"
    is Power.ring_1_class.power_minus_even.

tts_lemma power_minus_odd:
  assumes "a  U" and "odd n"
  shows "(-ow a) ^ow n = -ow (a ^ow n)"
    is Parity.ring_1_class.power_minus_odd.

tts_lemma uminus_power_if:
  assumes "a  U"
  shows "(-ow a) ^ow n = (if even n then a ^ow n else -ow (a ^ow n))"
    is Parity.ring_1_class.uminus_power_if.

tts_lemma neg_one_power_add_eq_neg_one_power_diff:
  assumes "k  n"
  shows "(-ow 1ow) ^ow (n + k) = (-ow 1ow) ^ow (n - k)"
    is Parity.ring_1_class.neg_one_power_add_eq_neg_one_power_diff.

tts_lemma neg_one_odd_power:
  assumes "odd n"
  shows "(-ow 1ow) ^ow n = -ow 1ow"
    is Parity.ring_1_class.neg_one_odd_power.

tts_lemma Ints_cases:
  assumes "q  «ℤ»" and "z. q = of_int z  thesis"
  shows thesis
    is Int.ring_1_class.Ints_cases.

end

end

lemmas [ud_with] = dvd.with dvd'.with



subsection‹Commutative rings with identity›


subsubsection‹Definitions and common properties›

locale comm_ring_1_ow =
  comm_ring_ow U plus zero minus uminus times + 
  zero_neq_one_ow U one zero + 
  comm_monoid_mult_ow U times one 
  for U :: "'ag set" and times one plus zero minus uminus
begin

sublocale ring_1_ow ..
sublocale comm_semiring_1_cancel_ow 
  by unfold_locales (blast intro: right_diff_distrib)

end

lemma comm_ring_1_ow: "class.comm_ring_1 = comm_ring_1_ow UNIV"
  unfolding 
    class.comm_ring_1_def comm_ring_1_ow_def
    comm_monoid_mult_ow comm_ring_ow zero_neq_one_ow
  by (force simp: conj_commute)

lemma comm_ring_1_ow_UNIV_axioms:
  "comm_ring_1_ow (UNIV::'a::comm_ring_1 set) (*) 1 (+) 0 (-) uminus"
  by (fold comm_ring_1_ow) (rule comm_ring_1_class.comm_ring_1_axioms)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma comm_ring_1_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===>
      A ===> 
      (A ===> A ===> A) ===>
      A ===>
      (A ===> A ===> A) ===> 
      (A ===> A) ===>
      (=)
    ) (comm_ring_1_ow (Collect (Domainp A))) class.comm_ring_1"
  unfolding comm_ring_1_ow_def class.comm_ring_1_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

end


subsubsection‹Relativization›

context comm_ring_1_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting comm_ring_1_ow_axioms and zero.not_empty
  applying 
    [
      OF 
        times_closed' 
        one_closed 
        plus_closed'
        zero_closed 
        minus_closed'
        add.inverse_closed''
    ]
begin

tts_lemma ring_normalization_rules:
  assumes "x  U"
  shows "-ow x = -ow 1ow *ow x" "y  U  x -ow y = x +ow -ow y"
    is comm_ring_1_class.ring_normalization_rules.
    
tts_lemma left_minus_one_mult_self:
  assumes "a  U"
  shows "(-ow 1ow) ^ow n *ow ((-ow 1ow) ^ow n *ow a) = a"
    is Power.comm_ring_1_class.left_minus_one_mult_self.

tts_lemma minus_power_mult_self:
  assumes "a  U"
  shows "(-ow a) ^ow n *ow (-ow a) ^ow n = a ^ow (2 * n)"
    is Power.comm_ring_1_class.minus_power_mult_self.

tts_lemma minus_one_mult_self: "(-ow 1ow) ^ow n *ow (-ow 1ow) ^ow n = 1ow"
  is comm_ring_1_class.minus_one_mult_self.

tts_lemma power2_commute:
  assumes "x  U" and "y  U"
  shows "(x -ow y) ^ow 2 = (y -ow x) ^ow 2"
    is comm_ring_1_class.power2_commute.

tts_lemma minus_dvd_iff:
  assumes "x  U" and "y  U"
  shows "(-ow x «dvd» y) = (x «dvd» y)"
    is comm_ring_1_class.minus_dvd_iff.

tts_lemma dvd_minus_iff:
  assumes "x  U" and "y  U"
  shows "(x «dvd» -ow y) = (x «dvd» y)"
    is comm_ring_1_class.dvd_minus_iff.

tts_lemma dvd_diff:
  assumes "x  U" and "y  U" and "z  U" and "x «dvd» y" and "x «dvd» z"
  shows "x «dvd» y -ow z"
    is comm_ring_1_class.dvd_diff.

end

end

text‹\newpage›

end

Theory SML_Semilattices

(* Title: Examples/SML_Relativization/Lattices/SML_Semilattices.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about semilattices›
theory SML_Semilattices
  imports 
    "../Simple_Orders/SML_Simple_Orders"
    "../Algebra/SML_Monoids"
begin



subsection‹Commutative bands›


subsubsection‹Definitions and common properties›

locale semilattice_ow = abel_semigroup_ow U f 
  for U :: "'al set" and f +
  assumes idem[simp]: "x  U  x *ow x = x"

locale semilattice_set_ow = 
  semilattice_ow U f for U :: "'al set" and f (infixl *ow 70)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semilattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (λf. semilattice_ow (Collect (Domainp A)) f) semilattice"
  unfolding
    semilattice_ow_def semilattice_def 
    semilattice_ow_axioms_def semilattice_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma semilattice_set_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> (=)) 
      (λf. semilattice_set_ow (Collect (Domainp A)) f) semilattice_set"
  unfolding semilattice_set_ow_def semilattice_set_def by transfer_prover

end


subsubsection‹Relativization›

context semilattice_ow 
begin

tts_context
  tts: (?'a to U)
  substituting semilattice_ow_axioms
  eliminating through simp
begin

tts_lemma left_idem:
  assumes "a  U" and "b  U"
  shows "a *ow (a *ow b) = a *ow b"
    is semilattice.left_idem.

tts_lemma right_idem:
  assumes "a  U" and "b  U"
  shows "a *ow b *ow b = a *ow b"
    is semilattice.right_idem.

end

end



subsection‹Simple upper and lower semilattices›


subsubsection‹Definitions and common properties›

locale semilattice_order_ow = semilattice_ow U f 
  for U :: "'al set" and f  +
  fixes le :: "['al, 'al]  bool" (infix ow 50)
    and ls :: "['al, 'al]  bool" (infix <ow 50)
  assumes order_iff: " a  U; b  U   a ow b  a = a *ow b"
    and strict_order_iff: " a  U; b  U   a <ow b  a = a *ow b  a  b"
begin

sublocale ordering_ow U (≤ow) (<ow)
proof
  show "a  U; b  U  (a <ow b) = (a ow b  a  b)" for a b
    apply standard
    subgoal by (auto simp: commute order_iff strict_order_iff)
    subgoal by (auto simp: order_iff strict_order_iff)
    done
  show "x  U  x ow x" for x by (simp add: order_iff)
  show " x  U; y  U; z  U; x ow y; y ow z   x ow z" for x y z
  proof-
    assume "x  U" and "y  U" and "z  U" and "x ow y" and "y ow z"
    note xy = order_iff[THEN iffD1, OF x  U y  U x ow y]
    note yz = order_iff[THEN iffD1, OF y  U z  U y ow z]
    note xz = assoc[OF x  U y  U z  U, folded xy yz, symmetric]
    show ?thesis by (rule order_iff[THEN iffD2, OF x  U z  U xz])
  qed
  show " x  U; y  U; x ow y; y ow x   x = y" for x y
    by (fastforce simp: commute order_iff)
qed

notation le (infix "ow" 50)
  and ls (infix "<ow" 50)

end

locale semilattice_order_set_ow = 
  semilattice_order_ow U f le ls + semilattice_set_ow U f
  for U :: "'al set" and f le ls  

locale inf_ow =
  fixes U :: "'al set" and inf (infixl ow 70)
  assumes inf_closed[simp]: " x  U; y  U   x ow y  U"
begin

notation inf (infixl ow 70)

lemma inf_closed'[simp]: "xU. yU. x ow y  U" by simp

end

locale inf_pair_ow = inf1: inf_ow U1 inf1 + inf2: inf_ow U2 inf2
  for U1 :: "'al set" and inf1
    and U2 :: "'bl set" and inf2
begin

notation inf1 (infixl ow.1 70)
notation inf2 (infixl ow.2 70)

end

locale semilattice_inf_ow = inf_ow U inf + order_ow U le ls 
  for U :: "'al set" and inf le ls  +
  assumes inf_le1[simp]: " x  U; y  U   x ow y ow x"
    and inf_le2[simp]: " x  U; y  U   x ow y ow y"
    and inf_greatest: 
      " x  U; y  U; z  U; x ow y; x ow z   x ow y ow z"
begin

sublocale inf: semilattice_order_ow U (⊓ow) (≤ow) (<ow)
proof

  show *: " a  U; b  U   a ow b  U" for a b by simp

  show **: " a  U; b  U; c  U   a ow b ow c = a ow (b ow c)" 
    for a b c
  proof -
    
    assume "a  U" and "b  U" and "c  U"
    from a  U b  U c  U have ab_c: "a ow b ow c  U" by simp
    from a  U b  U c  U have a_bc: "a ow (b ow c)  U" by simp

    from a  U b  U c  U have "a ow b ow c ow b" 
      by (meson * inf_le1 inf_le2 order_trans)
    moreover from a  U b  U c  U have "a ow b ow c ow c" by simp
    ultimately have abc_le_bc: "a ow b ow c ow b ow c"
      by (rule inf_greatest[OF ab_c b  U c  U])
    from a  U b  U c  U have abc_le_a: "a ow b ow c ow a" 
      by (meson inf_le1 order_trans inf_closed)
    note lhs = 
      inf_greatest[OF ab_c a  U *[OF b  U c  U] abc_le_a abc_le_bc]

    from a  U b  U c  U have "a ow (b ow c) ow a" 
      by (meson * inf_le1 order_trans)
    moreover from a  U b  U c  U have "a ow (b ow c) ow b" 
      by (meson * inf_le1 inf_le2 order_trans)
    ultimately have abc_le_bc: "a ow (b ow c) ow a ow b"
      by (rule inf_greatest[OF a_bc a  U b  U])
    from a  U b  U c  U have abc_le_a: "a ow (b ow c) ow c" 
      by (meson inf_le2 order_trans inf_closed)
    note rhs =
      inf_greatest[OF a_bc *[OF a  U b  U] c  U abc_le_bc abc_le_a] 
    show "a ow b ow c = a ow (b ow c)" 
      by (rule antisym[OF ab_c a_bc lhs rhs])
 
  qed

  show ***: " a  U; b  U   a ow b = b ow a" for a b
    by (simp add: eq_iff inf_greatest)

  show ****: "x  U  x ow x = x" for x
  proof-
    assume "x  U"
    have "x ow x ow x" by (simp add: x  U)
    moreover have "x ow x ow x" by (simp add: x  U inf_greatest)
    ultimately show "x ow x = x" by (simp add: x  U antisym)
  qed

  show *****: " a  U; b  U   (a ow b) = (a = a ow b)" for a b
    by (metis * *** eq_iff inf_greatest inf_le1 inf_le2)

  show " a  U; b  U   (a <ow b) = (a = a ow b  a  b)" for a b
    by (simp add: ***** less_le)

qed

sublocale Inf_fin: semilattice_order_set_ow U (⊓ow) (≤ow) (<ow) ..

end

locale semilattice_inf_pair_ow = 
  sl_inf1: semilattice_inf_ow U1 inf1 le1 ls1 +
  sl_inf2: semilattice_inf_ow U2 inf2 le2 ls2
  for U1 :: "'al set" and inf1 le1 ls1
    and U2 :: "'bl set" and inf2 le2 ls2
begin

sublocale inf_pair_ow ..
sublocale order_pair_ow ..

end

locale sup_ow =
  fixes U :: "'ao set" and sup :: "['ao, 'ao]  'ao" (infixl ow 70)
  assumes sup_closed[simp]: " x  U; y  U   sup x y  U"
begin

notation sup (infixl ow 70)

lemma sup_closed'[simp]: "xU. yU. x ow y  U" by simp

end

locale sup_pair_ow = sup1: sup_ow U1 sup1 + sup2: sup_ow U2 sup2
  for U1 :: "'al set" and sup1
    and U2 :: "'bl set" and sup2
begin

notation sup1 (infixl ow.1 70)
notation sup2 (infixl ow.2 70)

end

locale semilattice_sup_ow = sup_ow U sup + order_ow U le ls 
  for U :: "'al set" and sup le ls + 
  assumes sup_ge1[simp]: " x  U; y  U   x ow x ow y"
    and sup_ge2[simp]: " y  U; x  U   y ow x ow y"
    and sup_least: 
      " y  U; x  U; z  U; y ow x; z ow x   y ow z ow x"
begin

sublocale sup: semilattice_order_ow U (⊔ow) (≥ow) (>ow)
proof

  show *: " a  U; b  U   a ow b  U" for a b by simp

  show **: 
    " a  U; b  U; c  U   a ow b ow c = a ow (b ow c)" for a b c
  proof -
    
    assume "a  U" and "b  U" and "c  U"
    from a  U b  U c  U have ab_c: "a ow b ow c  U" by simp
    from a  U b  U c  U have a_bc: "a ow (b ow c)  U" by simp

    from a  U b  U c  U have "b ow a ow b ow c"
      by (meson order_trans sup_ge1 sup_ge2 sup_closed')
    moreover from a  U b  U c  U have "c ow a ow b ow c" by simp
    ultimately have ab_le_abc: "b ow c ow a ow b ow c"
      by (rule sup_least[OF b  U ab_c c  U])
    from a  U b  U c  U have a_le_abc: "a ow a ow b ow c" 
      by (meson "*" order_trans sup_ge1)
    note rhs = 
      sup_least[OF a  U ab_c *[OF b  U c  U] a_le_abc ab_le_abc]

    from a  U b  U c  U have "a ow a ow (b ow c)" by simp
    moreover from a  U b  U c  U have "b ow a ow (b ow c)" 
      by (meson order_trans sup_ge1 sup_ge2 sup_closed')
    ultimately have ab_le_abc: "a ow b ow a ow (b ow c)"
      by (rule sup_least[OF a  U a_bc b  U])
    from a  U b  U c  U have c_le_abc: "c ow a ow (b ow c)" 
      by (meson "*" order_trans sup_ge2)
    note lhs =
      sup_least[OF *[OF a  U b  U] a_bc c  U ab_le_abc c_le_abc]  
    show "a ow b ow c = a ow (b ow c)"
      by (rule antisym[OF ab_c a_bc lhs rhs])
 
  qed

  show ***: " a  U; b  U   a ow b = b ow a" for a b
    by (simp add: eq_iff sup_least)

  show ****: "x  U  x ow x = x" for x
  proof-
    assume "x  U"
    have "x ow x ow x" by (simp add: x  U)
    moreover have "x ow x ow x" by (simp add: x  U sup_least)
    ultimately show "x ow x = x" by (simp add: x  U antisym)
  qed

  show *****: " a  U; b  U   (a ow b) = (a = a ow b)" for a b 
    by (metis *** sup_ge2 sup_least eq_iff eq_refl sup_closed')

  show " a  U; b  U   (a >ow b) = (a = a ow b  a  b)" for a b
    by (auto simp: ***** less_le)

qed

sublocale Sup_fin: semilattice_order_set_ow U sup "(≥ow)" "(>ow)" ..

end


locale semilattice_sup_pair_ow = 
  sl_sup1: semilattice_sup_ow U1 sup1 le1 ls1 +
  sl_sup2: semilattice_sup_ow U2 sup2 le2 ls2
  for U1 :: "'al set" and sup1 le1 ls1
    and U2 :: "'bl set" and sup2 le2 ls2
begin

sublocale sup_pair_ow ..
sublocale order_pair_ow ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semilattice_order_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (=)
    ) (semilattice_order_ow (Collect (Domainp A))) semilattice_order"
  unfolding
    semilattice_order_ow_def semilattice_order_def 
    semilattice_order_ow_axioms_def semilattice_order_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma semilattice_order_set_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (=)
    ) (semilattice_order_set_ow (Collect (Domainp A))) semilattice_order_set"
  unfolding semilattice_order_set_ow_def semilattice_order_set_def 
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma semilattice_inf_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (=)
    ) (semilattice_inf_ow (Collect (Domainp A))) class.semilattice_inf"
proof -
  let ?P = 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    )"
  let ?semilattice_ow = "semilattice_inf_ow (Collect (Domainp A))"
  let ?rf_UNIV = 
    "(λinf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  inf x y  UNIV))"
  have 
    "?P 
    ?semilattice_ow 
    (λinf le ls. ?rf_UNIV inf  class.semilattice_inf inf le ls)"
    unfolding 
      class.semilattice_inf_def semilattice_inf_ow_def 
      class.semilattice_inf_axioms_def semilattice_inf_ow_axioms_def
      inf_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by fastforce
  then show ?thesis by simp
qed

lemma semilattice_sup_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (=)
    ) (semilattice_sup_ow (Collect (Domainp A))) class.semilattice_sup"
proof -
  let ?P = 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (=)
    )"
  let ?semilattice_ow = "semilattice_sup_ow (Collect (Domainp A))"
  let ?rf_UNIV = 
    "(λsup::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  sup x y  UNIV))"
  have 
    "?P 
    ?semilattice_ow 
    (λsup le ls. ?rf_UNIV sup  class.semilattice_sup sup le ls)"
  unfolding 
    class.semilattice_sup_def semilattice_sup_ow_def 
    class.semilattice_sup_axioms_def semilattice_sup_ow_axioms_def
    sup_ow_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_def by fastforce
  then show ?thesis by simp
qed

end


subsubsection‹Relativization›

context semilattice_order_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semilattice_order_ow_axioms
  eliminating through simp
begin

tts_lemma cobounded1:
  assumes "a  U" and "b  U"
  shows "a *ow b ow a"
    is semilattice_order.cobounded1.
    
tts_lemma cobounded2:
  assumes "a  U" and "b  U"
  shows "a *ow b ow b"
    is semilattice_order.cobounded2.

tts_lemma absorb_iff1:
  assumes "a  U" and "b  U"
  shows "(a ow b) = (a *ow b = a)"
    is semilattice_order.absorb_iff1.

tts_lemma absorb_iff2:
  assumes "b  U" and "a  U"
  shows "(b ow a) = (a *ow b = b)"
    is semilattice_order.absorb_iff2.

tts_lemma strict_coboundedI1:
  assumes "a  U" and "c  U" and "b  U" and "a <ow c"
  shows "a *ow b <ow c"
    is semilattice_order.strict_coboundedI1.

tts_lemma strict_coboundedI2:
  assumes "b  U" and "c  U" and "a  U" and "b <ow c"
  shows "a *ow b <ow c"
    is semilattice_order.strict_coboundedI2.

tts_lemma absorb1:
  assumes "a  U" and "b  U" and "a ow b"
  shows "a *ow b = a"
    is semilattice_order.absorb1.

tts_lemma coboundedI1:
  assumes "a  U" and "c  U" and "b  U" and "a ow c"
  shows "a *ow b ow c"
    is semilattice_order.coboundedI1.

tts_lemma absorb2:
  assumes "b  U" and "a  U" and "b ow a"
  shows "a *ow b = b"
    is semilattice_order.absorb2.

tts_lemma coboundedI2:
  assumes "b  U" and "c  U" and "a  U" and "b ow c"
  shows "a *ow b ow c"
    is semilattice_order.coboundedI2.

tts_lemma orderI:
  assumes "a  U" and "b  U" and "a = a *ow b"
  shows "a ow b"
    is semilattice_order.orderI.

tts_lemma bounded_iff:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a ow b *ow c) = (a ow b  a ow c)"
    is semilattice_order.bounded_iff.

tts_lemma boundedI:
  assumes "a  U" and "b  U" and "c  U" and "a ow b" and "a ow c"
  shows "a ow b *ow c"
    is semilattice_order.boundedI.

tts_lemma orderE:
  assumes "a  U" and "b  U"  and "a ow b" and "a = a *ow b  thesis"
  shows thesis
    is semilattice_order.orderE.

tts_lemma mono:
  assumes "a  U"
    and "c  U"
    and "b  U"
    and "d  U"
    and "a ow c"
    and "b ow d"
  shows "a *ow b ow c *ow d"
    is semilattice_order.mono.

tts_lemma strict_boundedE:
  assumes "a  U"
    and "b  U"
    and "c  U"
    and "a <ow b *ow c"
  obtains "a <ow b" and "a <ow c"
    given semilattice_order.strict_boundedE by auto

tts_lemma boundedE:
  assumes "a  U"
    and "b  U"
    and "c  U"
    and "a ow b *ow c"
  obtains "a ow b" and "a ow c"
    given semilattice_order.boundedE by auto

end

end

context semilattice_inf_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semilattice_inf_ow_axioms
  eliminating through simp
begin

tts_lemma le_iff_inf:
  assumes "x  U" and "y  U"
  shows "(x ow y) = (x ow y = x)"
    is semilattice_inf_class.le_iff_inf.
    
tts_lemma less_infI1:
  assumes "a  U" and "x  U" and "b  U" and "a <ow x"
  shows "a ow b <ow x"
    is semilattice_inf_class.less_infI1.

tts_lemma less_infI2:
  assumes "b  U" and "x  U" and "a  U" and "b <ow x"
  shows "a ow b <ow x"
    is semilattice_inf_class.less_infI2.

tts_lemma le_infI1:
  assumes "a  U" and "x  U" and "b  U" and "a ow x"
  shows "a ow b ow x"
    is semilattice_inf_class.le_infI1.

tts_lemma le_infI2:
  assumes "b  U" and "x  U" and "a  U" and "b ow x"
  shows "a ow b ow x"
    is semilattice_inf_class.le_infI2.

tts_lemma le_inf_iff:
  assumes "x  U" and "y  U" and "z  U"
  shows "(x ow y ow z) = (x ow y  x ow z)"
    is semilattice_inf_class.le_inf_iff.

tts_lemma le_infI:
  assumes "x  U" and "a  U" and "b  U" and "x ow a" and "x ow b"
  shows "x ow a ow b"
    is semilattice_inf_class.le_infI.

tts_lemma le_infE:
  assumes "x  U"
    and "a  U"
    and "b  U"
    and "x ow a ow b"
    and "x ow a; x ow b  P"
  shows P
    is semilattice_inf_class.le_infE.

tts_lemma inf_mono:
  assumes "a  U"
    and "c  U"
    and "b  U"
    and "d  U"
    and "a ow c"
    and "b ow d"
  shows "a ow b ow c ow d"
    is semilattice_inf_class.inf_mono.

end

end

context semilattice_sup_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting semilattice_sup_ow_axioms
  eliminating through simp
begin

tts_lemma le_iff_sup:
  assumes "x  U" and "y  U"
  shows "(x ow y) = (x ow y = y)"
    is semilattice_sup_class.le_iff_sup.

tts_lemma less_supI1:
  assumes "x  U" and "a  U" and "b  U" and "x <ow a"
  shows "x <ow a ow b"
    is semilattice_sup_class.less_supI1.

tts_lemma less_supI2:
  assumes "x  U" and "b  U" and "a  U" and "x <ow b"
  shows "x <ow a ow b"
    is semilattice_sup_class.less_supI2.

tts_lemma le_supI1:
  assumes "x  U" and "a  U" and "b  U" and "x ow a"
  shows "x ow a ow b"
    is semilattice_sup_class.le_supI1.

tts_lemma le_supI2:
  assumes "x  U" and "b  U" and "a  U" and "x ow b"
  shows "x ow a ow b"
    is semilattice_sup_class.le_supI2.

tts_lemma le_sup_iff:
  assumes "x  U" and "y  U" and "z  U"
  shows "(x ow y ow z) = (x ow z  y ow z)"
    is semilattice_sup_class.le_sup_iff.

tts_lemma le_supI:
  assumes "a  U" and "x  U" and "b  U" and "a ow x" and "b ow x"
  shows "a ow b ow x"
    is semilattice_sup_class.le_supI.

tts_lemma le_supE:
  assumes "a  U"
    and "b  U"
    and "x  U"
    and "a ow b ow x"
    and "a ow x; b ow x  P"
  shows P
    is semilattice_sup_class.le_supE.

tts_lemma sup_unique:
  assumes "xU. yU. f x y  U"
    and "x  U"
    and "y  U"
    and "x y. x  U; y  U  x ow f x y"
    and "x y. x  U; y  U  y ow f x y"
    and "x y z. x  U; y  U; z  U; y ow x; z ow x  f y z ow x"
  shows "x ow y = f x y"
    is semilattice_sup_class.sup_unique.

tts_lemma sup_mono:
  assumes "a  U"
    and "c  U"
    and "b  U"
    and "d  U"
    and "a ow c"
    and "b ow d"
  shows "a ow b ow c ow d"
    is semilattice_sup_class.sup_mono.

end

end



subsection‹Bounded semilattices›


subsubsection‹Definitions and common properties›

locale semilattice_neutral_ow = semilattice_ow U f + comm_monoid_ow U f z
  for U :: "'al set" and f z

locale semilattice_neutral_order_ow = 
  sl_neut: semilattice_neutral_ow U f z + 
  sl_ord: semilattice_order_ow U f le ls
  for U :: "'al set" and f z le ls 
begin

sublocale order_top_ow U (≤ow) (<ow) 1ow
  apply unfold_locales
  subgoal by (auto simp: antisym sl_ord.strict_iff_order sl_ord.antisym)
  subgoal by (auto simp: sl_ord.order_iff)
  subgoal by (auto intro: sl_ord.trans)
  subgoal by (auto simp: sl_ord.antisym)
  subgoal by auto
  subgoal by (simp add: sl_ord.absorb_iff1)
  done

end

locale bounded_semilattice_inf_top_ow =
  semilattice_inf_ow U inf le ls + order_top_ow U le ls top
  for U :: "'al set" and inf le ls top 
begin

sublocale inf_top: semilattice_neutral_order_ow U (⊓ow) ow (≤ow) (<ow)
  apply unfold_locales
  subgoal by simp
  subgoal using top_greatest by (simp add: inf.order_iff)
  done

end

locale bounded_semilattice_sup_bot_ow = 
  semilattice_sup_ow U sup le ls + order_bot_ow U bot le ls
  for U :: "'al set" and sup le ls bot
begin

sublocale sup_bot: semilattice_neutral_order_ow U (⊔ow) ow (≥ow) (>ow)
  by unfold_locales (simp_all add: sup.absorb1)

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semilattice_neutral_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> A) ===> A ===> (=))
      (semilattice_neutral_ow (Collect (Domainp A))) semilattice_neutr"
  unfolding semilattice_neutral_ow_def semilattice_neutr_def by transfer_prover
  
lemma semilattice_neutr_order_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      A ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (=)
    )
    (semilattice_neutral_order_ow (Collect (Domainp A))) 
    semilattice_neutr_order"
  unfolding semilattice_neutral_order_ow_def semilattice_neutr_order_def 
  by transfer_prover

lemma bounded_semilattice_inf_top_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      A ===> 
      (=)
    ) 
    (bounded_semilattice_inf_top_ow (Collect (Domainp A))) 
    class.bounded_semilattice_inf_top"
  unfolding
    bounded_semilattice_inf_top_ow_def class.bounded_semilattice_inf_top_def
  by transfer_prover

lemma bounded_semilattice_sup_bot_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      A ===> 
      (=)
    ) 
    (bounded_semilattice_sup_bot_ow (Collect (Domainp A))) 
    class.bounded_semilattice_sup_bot"
  unfolding
    bounded_semilattice_sup_bot_ow_def class.bounded_semilattice_sup_bot_def
  by transfer_prover

end

text‹\newpage›

end

Theory SML_Lattices

(* Title: Examples/SML_Relativization/Lattices/SML_Lattices.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the the results about lattices›
theory SML_Lattices
  imports SML_Semilattices
begin



subsection‹Simple lattices›


subsubsection‹Definitions and common properties›

locale lattice_ow = 
  semilattice_inf_ow U inf le ls + semilattice_sup_ow U sup le ls 
  for U :: "'al set" and inf le ls sup

locale lattice_pair_ow = 
  lattice1: lattice_ow U1 inf1 le1 ls1 sup1 +
  lattice2: lattice_ow U2 inf2 le2 ls2 sup2
  for U1 :: "'al set" and inf1 le1 ls1 sup1
    and U2 :: "'bl set" and inf2 le2 ls2 sup2
begin

sublocale semilattice_inf_pair_ow ..
sublocale semilattice_sup_pair_ow ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma lattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> A) ===> 
      (=)
    )
    (lattice_ow (Collect (Domainp A))) class.lattice"
  unfolding class.lattice_def lattice_ow_def by transfer_prover
  
end


subsubsection‹Relativization›

context lattice_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting lattice_ow_axioms
  eliminating through simp
begin

tts_lemma inf_sup_aci:
  assumes "x  U" and "y  U"
  shows 
    "x ow y = y ow x"
    "z  U  x ow y ow z = x ow (y ow z)"
    "z  U  x ow (y ow z) = y ow (x ow z)"
    "x ow (x ow y) = x ow y"
    "x ow y = y ow x"
    "z  U  x ow y ow z = x ow (y ow z)"
    "z  U  x ow (y ow z) = y ow (x ow z)"
    "x ow (x ow y) = x ow y"
    is lattice_class.inf_sup_aci.
    
tts_lemma inf_sup_absorb:
  assumes "x  U" and "y  U"
  shows "x ow (x ow y) = x"
    is lattice_class.inf_sup_absorb.

tts_lemma sup_inf_absorb:
  assumes "x  U" and "y  U"
  shows "x ow (x ow y) = x"
    is lattice_class.sup_inf_absorb.
    
tts_lemma bdd_above_insert:
  assumes "a  U" and "A  U"
  shows "local.bdd_above (insert a A) = local.bdd_above A"
    is lattice_class.bdd_above_insert.

tts_lemma bdd_below_insert:
  assumes "a  U" and "A  U"
  shows "local.bdd_below (insert a A) = local.bdd_below A"
  is lattice_class.bdd_below_insert.
    
tts_lemma distrib_sup_le:
  assumes "x  U" and "y  U" and "z  U"
  shows "x ow (y ow z) ow x ow y ow (x ow z)"
    is lattice_class.distrib_sup_le.

tts_lemma distrib_inf_le:
  assumes "x  U" and "y  U" and "z  U"
  shows "x ow y ow (x ow z) ow x ow (y ow z)"
    is lattice_class.distrib_inf_le.

tts_lemma distrib_imp1:
  assumes "x  U"
    and "y  U"
    and "z  U"
    and 
      "x y z. x  U; y  U; z  U  
        x ow (y ow z) = x ow y ow (x ow z)"
  shows "x ow (y ow z) = x ow y ow (x ow z)"
    is lattice_class.distrib_imp1.

tts_lemma distrib_imp2:
  assumes "x  U"
    and "y  U"
    and "z  U"
    and 
      "x y z. x  U; y  U; z  U  
        x ow (y ow z) = x ow y ow (x ow z)"
  shows "x ow (y ow z) = x ow y ow (x ow z)"
    is lattice_class.distrib_imp2.

tts_lemma bdd_above_Un:
  assumes "A  U" and "B  U"
  shows "local.bdd_above (A  B) = (local.bdd_above A  local.bdd_above B)"
    is lattice_class.bdd_above_Un.

tts_lemma bdd_below_Un:
  assumes "A  U" and "B  U"
  shows "local.bdd_below (A  B) = (local.bdd_below A  local.bdd_below B)"
    is lattice_class.bdd_below_Un.

tts_lemma bdd_above_image_sup:
  assumes "range f  U" and "range g  U"
  shows "local.bdd_above ((λx. f x ow g x) ` A) = 
    (local.bdd_above (f ` A)  local.bdd_above (g ` A))"
    is lattice_class.bdd_above_image_sup.

tts_lemma bdd_below_image_inf:
  assumes "range f  U" and "range g  U"
  shows "local.bdd_below ((λx. f x ow g x) ` A) = 
    (local.bdd_below (f ` A)  local.bdd_below (g ` A))"
    is lattice_class.bdd_below_image_inf.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting lattice_ow_axioms
  eliminating through simp
begin

tts_lemma bdd_above_UN:
  assumes "U  {}" and "range A  Pow U" and "finite I"
  shows "bdd_above ( (A ` I)) = (xI. bdd_above (A x))"
    is lattice_class.bdd_above_UN .

tts_lemma bdd_below_UN:
  assumes "U  {}" and "range A  Pow U" and "finite I"
  shows "local.bdd_below ( (A ` I)) = (xI. local.bdd_below (A x))"
    is lattice_class.bdd_below_UN.
    
tts_lemma bdd_above_finite:
  assumes "U  {}" and "A  U" and "finite A"
  shows "local.bdd_above A"
    is lattice_class.bdd_above_finite.

tts_lemma bdd_below_finite:
  assumes "U  {}" and "A  U" and "finite A"
  shows "local.bdd_below A"
    is lattice_class.bdd_below_finite.

end

end



subsection‹Bounded lattices›


subsubsection‹Definitions and common properties›

locale bounded_lattice_bot_ow = 
  lattice_ow U inf le ls sup + order_bot_ow U bot le ls
  for U :: "'al set" and inf le ls sup bot
begin

sublocale bounded_semilattice_sup_bot_ow U (⊔ow) (≤ow) (<ow) ow ..

end

locale bounded_lattice_bot_pair_ow = 
  blb1: bounded_lattice_bot_ow U1 inf1 le1 ls1 sup1 bot1 +
  blb2: bounded_lattice_bot_ow U2 inf2 le2 ls2 sup2 bot2
  for U1 :: "'al set" and inf1 le1 ls1 sup1 bot1
    and U2 :: "'bl set" and inf2 le2 ls2 sup2 bot2
begin

sublocale lattice_pair_ow ..
sublocale order_bot_pair_ow U1 bot1 le1 ls1 U2 bot2 le2 ls2 ..

end

locale bounded_lattice_top_ow = 
  lattice_ow U inf le ls sup + order_top_ow U le ls top
  for U :: "'al set" and inf le ls sup top 
begin

sublocale bounded_semilattice_inf_top_ow U (⊓ow) (≤ow) (<ow) ow ..

end

locale bounded_lattice_top_pair_ow = 
  blb1: bounded_lattice_top_ow U1 inf1 le1 ls1 sup1 top1 +
  blb2: bounded_lattice_top_ow U2 inf2 le2 ls2 sup2 top2
  for U1 :: "'al set" and inf1 le1 ls1 sup1 top1
    and U2 :: "'bl set" and inf2 le2 ls2 sup2 top2
begin

sublocale lattice_pair_ow ..
sublocale order_top_pair_ow U1 le1 ls1 top1 U2 le2 ls2 top2 ..

end

locale bounded_lattice_ow = 
  lattice_ow U inf le ls sup + 
  order_bot_ow U bot le ls + 
  order_top_ow U le ls top
  for U :: "'al set" and inf le ls sup bot top
begin

sublocale bounded_lattice_bot_ow U (⊓ow) (≤ow) (<ow) (⊔ow) ow ..
sublocale bounded_lattice_top_ow U (⊓ow) (≤ow) (<ow) (⊔ow) ow ..

end

locale bounded_lattice_pair_ow = 
  bl1: bounded_lattice_ow U1 inf1 le1 ls1 sup1 bot1 top1 +
  bl2: bounded_lattice_ow U2 inf2 le2 ls2 sup2 bot2 top2
  for U1 :: "'al set" and inf1 le1 ls1 sup1 bot1 top1 
    and U2 :: "'bl set" and inf2 le2 ls2 sup2 bot2 top2
begin

sublocale bounded_lattice_bot_pair_ow ..
sublocale bounded_lattice_top_pair_ow ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma bounded_lattice_bot_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      (=)
    ) 
    (bounded_lattice_bot_ow (Collect (Domainp A))) 
    class.bounded_lattice_bot"
  unfolding bounded_lattice_bot_ow_def class.bounded_lattice_bot_def
  by transfer_prover

lemma bounded_lattice_top_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "
    (
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      (=)
    ) 
      (bounded_lattice_top_ow (Collect (Domainp A))) 
      class.bounded_lattice_top"
  unfolding bounded_lattice_top_ow_def class.bounded_lattice_top_def
  by transfer_prover

lemma bounded_lattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> A) ===> 
      A ===> 
      A ===> 
      (=)
    ) 
    (bounded_lattice_ow (Collect (Domainp A))) class.bounded_lattice"
  unfolding bounded_lattice_ow_def class.bounded_lattice_def by transfer_prover

end


subsubsection‹Relativization›

context bounded_lattice_bot_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting bounded_lattice_bot_ow_axioms and sup_bot.sl_neut.not_empty
  applying [OF inf_closed' sup_closed' bot_closed]
begin

tts_lemma inf_bot_left:
  assumes "x  U"
  shows "ow ow x = ow"
    is bounded_lattice_bot_class.inf_bot_left.

tts_lemma inf_bot_right:
  assumes "x  U"
  shows "x ow ow = ow"
    is bounded_lattice_bot_class.inf_bot_right.

end

end

context bounded_lattice_top_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting bounded_lattice_top_ow_axioms and inf_top.sl_neut.not_empty
  applying [OF inf_closed' sup_closed' top_closed]
begin
    
tts_lemma sup_top_left:
  assumes "x  U"
  shows "ow ow x = ow"
    is bounded_lattice_top_class.sup_top_left.
    
tts_lemma sup_top_right:
  assumes "x  U"
  shows "x ow ow = ow"
    is bounded_lattice_top_class.sup_top_right.
    
end

end

context bounded_lattice_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting bounded_lattice_ow_axioms 
  applying [OF sup_bot.sl_neut.not_empty, simplified]
begin

tts_lemma atLeastAtMost_eq_UNIV_iff:
  assumes "x  U" and "y  U"
  shows "({x..owy} = U) = (x = ow  y = ow)"
    is bounded_lattice_class.atLeastAtMost_eq_UNIV_iff.

end

end



subsection‹Distributive lattices›


subsubsection‹Definitions and common properties›

locale distrib_lattice_ow =
  lattice_ow U inf le ls sup for U :: "'al set" and inf le ls sup  +
  assumes sup_inf_distrib1: 
    " x  U; y  U; z  U   x ow (y ow z) = (x ow y) ow (x ow z)"


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma distrib_lattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> A) ===> 
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> A) ===> 
      (=)
    )
    (distrib_lattice_ow (Collect (Domainp A))) class.distrib_lattice"
  unfolding 
    distrib_lattice_ow_def class.distrib_lattice_def  
    class.distrib_lattice_axioms_def distrib_lattice_ow_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp
  
end


subsubsection‹Relativization›

context distrib_lattice_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting distrib_lattice_ow_axioms
  eliminating through simp
begin

tts_lemma inf_sup_distrib1:
  assumes "x  U" and "y  U" and "z  U"
  shows "x ow (y ow z) = x ow y ow (x ow z)"
  is distrib_lattice_class.inf_sup_distrib1.

tts_lemma inf_sup_distrib2:
  assumes "y  U" and "z  U" and "x  U"
  shows "y ow z ow x = y ow x ow (z ow x)"
    is distrib_lattice_class.inf_sup_distrib2.

tts_lemma sup_inf_distrib2:
  assumes "y  U" and "z  U" and "x  U"
  shows "y ow z ow x = y ow x ow (z ow x)"
    is distrib_lattice_class.sup_inf_distrib2.

end

end

text‹\newpage›

end

Theory SML_Complete_Lattices

(* Title: Examples/SML_Relativization/Lattices/SML_Complete_Lattices.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about complete lattices›
theory SML_Complete_Lattices
  imports SML_Lattices
begin



subsection‹Simple complete lattices›


subsubsection‹Definitions and common properties›

locale Inf_ow = 
  fixes U :: "'al set" and Inf (ow)
  assumes Inf_closed[simp]: "ow ` Pow U  U"
begin

notation Inf (ow)

lemma Inf_closed'[simp]: "xU. ow x  U" using Inf_closed by blast

end

locale Inf_pair_ow = Inf1: Inf_ow U1 Inf1 + Inf2: Inf_ow U2 Inf2 
  for U1 :: "'al set" and Inf1 and U2 :: "'bl set" and Inf2
begin

notation Inf1 (ow.1)
notation Inf2 (ow.2)

end

locale Sup_ow = 
  fixes U :: "'al set" and Sup (ow)
  assumes Sup_closed[simp]: "ow ` Pow U  U"
begin

notation Sup (ow)

lemma Sup_closed'[simp]: "xU. ow x  U" using Sup_closed by blast

end

locale Sup_pair_ow = Sup1: Sup_ow U1 Sup1 + Sup2: Sup_ow U2 Sup2 
  for U1 :: "'al set" and Sup1 and U2 :: "'bl set" and Sup2
begin

notation Sup1 (ow.1)
notation Sup2 (ow.2)

end

locale complete_lattice_ow =
  lattice_ow U inf le ls sup +
  Inf_ow U Inf + 
  Sup_ow U Sup + 
  bot_ow U bot + 
  top_ow U top
  for U :: "'al set" and Inf  Sup inf le ls sup bot top +
  assumes Inf_lower: " A  U; x  A   ow A ow x"
    and Inf_greatest: 
      " A  U; z  U; (x. x  A  z ow x)   z ow ow A"
    and Sup_upper: " x  A; A  U   x ow ow A"
    and Sup_least: 
      " A  U; z  U; (x. x  A  x ow z)   ow A ow z"
    and Inf_empty[simp]: "ow {} = ow"
    and Sup_empty[simp]: "ow {} = ow"
begin

sublocale bounded_lattice_ow U (⊓ow) (≤ow) (<ow) (⊔ow) ow ow
  apply standard
  subgoal using Sup_least by force
  subgoal using Inf_greatest by fastforce
  done

tts_register_sbts ow | U
proof-
  assume ALA: "Domainp ALA = (λx. x  U)" 
  have "Domainp ALA ow" unfolding ALA by simp
  then obtain bot' where "ALA ow bot'" by blast
  then show "bot'. ALA ow bot'" by auto
qed

tts_register_sbts ow | U
proof-
  assume ALA: "Domainp ALA = (λx. x  U)" 
  have "Domainp ALA ow" unfolding ALA by simp
  then obtain top' where "ALA ow top'" by blast
  then show "top'. ALA ow top'" by auto
qed

end

locale complete_lattice_pair_ow = 
  cl1: complete_lattice_ow U1 Inf1 Sup1 inf1 le1 ls1 sup1 bot1 top1 + 
  cl2: complete_lattice_ow U2 Inf2 Sup2 inf2 le2 ls2 sup2 bot2 top2 
  for U1 :: "'al set" and Inf1 Sup1 inf1 le1 ls1 sup1 bot1 top1
    and U2 :: "'bl set" and Inf2 Sup2 inf2 le2 ls2 sup2 bot2 top2
begin

sublocale bounded_lattice_pair_ow ..
sublocale Inf_pair_ow ..
sublocale Sup_pair_ow ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma complete_lattice_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (rel_set A ===> A) ===> 
      (rel_set A ===> A) ===>
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> A) ===> 
      A ===> A ===>
      (=)
    )
    (complete_lattice_ow (Collect (Domainp A))) class.complete_lattice"
proof-
  let ?P = 
    "(
      (rel_set A ===> A) ===> 
      (rel_set A ===> A) ===>
      (A ===> A ===> A) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> (=)) ===>
      (A ===> A ===> A) ===> 
      A ===> A ===>
      (=)
    )"
  let ?complete_lattice_ow = "(complete_lattice_ow (Collect (Domainp A)))"
  let ?Inf_Sup_UNIV = 
    "(λF'::'b set  'b. (F' ` Pow UNIV  UNIV))"
  have rrng:
    "((A2  A3  A4  A5  A1  A6  A7  A8  A9  A10  A11) = F') 
    ((A1  A2  A3  A4  A5  A6  A7  A8  A9  A10  A11) = F')"
    for A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11 F'
    by auto
  have 
    "?P 
      ?complete_lattice_ow
      (
        λInf Sup inf le ls sup bot top. 
          ?Inf_Sup_UNIV Inf  ?Inf_Sup_UNIV Sup  bot  UNIV  top  UNIV 
          class.complete_lattice Inf Sup inf le ls sup bot top
      )"
    unfolding 
      complete_lattice_ow_def class.complete_lattice_def
      complete_lattice_ow_axioms_def class.complete_lattice_axioms_def
      Inf_ow_def Sup_ow_def bot_ow_def top_ow_def
    apply transfer_prover_start
    apply transfer_step+
    apply(simp, intro ext, rule rrng, intro arg_cong2[where f="(∧)"])
    subgoal unfolding Ball_Collect by simp
    subgoal unfolding Ball_Collect by simp
    subgoal by simp
    subgoal by simp
    subgoal by simp
    subgoal unfolding Ball_Collect[symmetric] by auto
    subgoal unfolding Ball_Collect[symmetric] by metis
    subgoal unfolding Ball_Collect[symmetric] by auto
    subgoal unfolding Ball_Collect[symmetric] by metis
    subgoal by simp
    subgoal by simp
    done
  then show ?thesis by simp
qed
  
end


subsubsection‹Relativization›

context complete_lattice_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating ?a  ?A and ?A  ?B through auto
  applying [OF Inf_closed' Sup_closed' inf_closed' sup_closed']
begin

tts_lemma Inf_atLeast:
  assumes "x  U"
  shows "ow {x..ow} = x"
  is complete_lattice_class.Inf_atLeast.
    
tts_lemma Inf_atMost:
  assumes "x  U"
  shows "ow {..owx} = ow"
    is complete_lattice_class.Inf_atMost.
    
tts_lemma Sup_atLeast:
  assumes "x  U"
  shows "ow {x..ow} = ow"
  is complete_lattice_class.Sup_atLeast.
    
tts_lemma Sup_atMost:
  assumes "y  U"
  shows "ow {..owy} = y"
    is complete_lattice_class.Sup_atMost.
    
tts_lemma Inf_insert:
  assumes "a  U" and "A  U"
  shows "ow (insert a A) = a ow ow A"
    is complete_lattice_class.Inf_insert.
    
tts_lemma Sup_insert:
  assumes "a  U" and "A  U"
  shows "ow (insert a A) = a ow ow A"
    is complete_lattice_class.Sup_insert.
    
tts_lemma Inf_atMostLessThan:
  assumes "x  U" and "ow <ow x"
  shows "ow {..<owx} = ow"
    is complete_lattice_class.Inf_atMostLessThan.
    
tts_lemma Sup_greaterThanAtLeast:
  assumes "x  U" and "x <ow ow"
  shows "ow {x<ow..} = ow"
    is complete_lattice_class.Sup_greaterThanAtLeast.
    
tts_lemma le_Inf_iff:
  assumes "b  U" and "A  U"
  shows "(b ow ow A) = Ball A ((≤ow) b)"
    is complete_lattice_class.le_Inf_iff.
    
tts_lemma Sup_le_iff:
  assumes "A  U" and "b  U"
  shows "(ow A ow b) = (xA. x ow b)"
    is complete_lattice_class.Sup_le_iff.
    
tts_lemma Inf_atLeastLessThan:
  assumes "x  U" and "y  U" and "x <ow y"
  shows "ow (on U with (≤ow) (<ow) : {x..<y}) = x"
    is complete_lattice_class.Inf_atLeastLessThan.
    
tts_lemma Sup_greaterThanAtMost:
  assumes "x  U" and "y  U" and "x <ow y"
  shows "ow {x<ow..y} = y"
    is complete_lattice_class.Sup_greaterThanAtMost.
    
tts_lemma Inf_atLeastAtMost:
  assumes "x  U" and "y  U" and "x ow y"
  shows "ow {x..owy} = x"
is complete_lattice_class.Inf_atLeastAtMost.
    
tts_lemma Sup_atLeastAtMost:
  assumes "x  U" and "y  U" and "x ow y"
  shows "ow {x..owy} = y"
    is complete_lattice_class.Sup_atLeastAtMost.
    
tts_lemma Inf_lower2:
  assumes "A  U" and "v  U" and "u  A" and "u ow v"
  shows "ow A ow v"
  is complete_lattice_class.Inf_lower2.
    
tts_lemma Sup_upper2:
  assumes "A  U" and "v  U" and "u  A" and "v ow u"
  shows "v ow ow A"
    is complete_lattice_class.Sup_upper2.
    
tts_lemma Inf_less_eq:
  assumes "A  U" and "u  U" and "v. v  A  v ow u" and "A  {}"
  shows "ow A ow u"
  given complete_lattice_class.Inf_less_eq by auto

tts_lemma less_eq_Sup:
  assumes "A  U" and "u  U" and "v. v  A  u ow v" and "A  {}"
  shows "u ow ow A"
  given complete_lattice_class.less_eq_Sup by auto

tts_lemma Sup_eqI:
  assumes "A  U"
    and "x  U"
    and "y. y  A  y ow x"
    and "y. y  U; z. z  A  z ow y  x ow y"
  shows "ow A = x"
    given complete_lattice_class.Sup_eqI
    by (simp add: Sup_least Sup_upper order.antisym)
    
tts_lemma Inf_eqI:
  assumes "A  U"
    and "x  U"
    and "i. i  A  x ow i"
    and "y. y  U; i. i  A  y ow i  y ow x"
  shows "ow A = x"
    given complete_lattice_class.Inf_eqI 
  by (simp add: subset_eq)

tts_lemma Inf_union_distrib:
  assumes "A  U" and "B  U"
  shows "ow (A  B) = ow A ow ow B"
    is complete_lattice_class.Inf_union_distrib.

tts_lemma Sup_union_distrib:
  assumes "A  U" and "B  U"
  shows "ow (A  B) = ow A ow ow B"
    is complete_lattice_class.Sup_union_distrib.

tts_lemma Sup_inter_less_eq:
  assumes "A  U" and "B  U"
  shows "ow (A  B) ow ow A ow ow B"
    is complete_lattice_class.Sup_inter_less_eq.

tts_lemma less_eq_Inf_inter:
  assumes "A  U" and "B  U"
  shows "ow A ow ow B ow ow (A  B)"
    is complete_lattice_class.less_eq_Inf_inter.

tts_lemma Sup_subset_mono:
  assumes "B  U" and "A  B"
  shows "ow A ow ow B"
    is complete_lattice_class.Sup_subset_mono.

tts_lemma Inf_superset_mono:
  assumes "A  U" and "B  A"
  shows "ow A ow ow B"
    is complete_lattice_class.Inf_superset_mono.

tts_lemma Sup_bot_conv:
  assumes "A  U" 
  shows 
    "(ow A = ow) = (xA. x = ow)"
    "(ow = ow A) = (xA. x = ow)"
    is complete_lattice_class.Sup_bot_conv.

tts_lemma Inf_top_conv:
  assumes "A  U"
  shows 
    "(ow A = ow) = (xA. x = ow)" 
    "(ow = ow A) = (xA. x = ow)"
    is complete_lattice_class.Inf_top_conv.

tts_lemma Inf_le_Sup:
  assumes "A  U" and "A  {}"
  shows "ow A ow ow A"
    is complete_lattice_class.Inf_le_Sup.

tts_lemma INF_UNIV_bool_expand:
  assumes "range A  U"
  shows "ow (range A) = A True ow A False"
    is complete_lattice_class.INF_UNIV_bool_expand.

tts_lemma SUP_UNIV_bool_expand:
  assumes "range A  U"
  shows "ow (range A) = A True ow A False"
    is complete_lattice_class.SUP_UNIV_bool_expand.

tts_lemma Sup_mono:
  assumes "A  U" and "B  U" and "a. a  A  Bex B ((≤ow) a)"
  shows "ow A ow ow B"
    given complete_lattice_class.Sup_mono by simp

tts_lemma Inf_mono:
  assumes "B  U"
    and "A  U"
    and "b. b  B  xA. x ow b"
  shows "ow A ow ow B"
    given complete_lattice_class.Inf_mono by simp

tts_lemma Sup_Inf_le:
  assumes "A  Pow U"
  shows "ow 
    (
      ow ` {x. x  U  (f{f. f ` Pow U  U}. x = f ` A  (YA. f Y  Y))}
    ) ow ow (ow ` A)"
    is complete_lattice_class.Sup_Inf_le.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty 
  applying [
    OF Inf_closed' Sup_closed' inf_closed' sup_closed' bot_closed top_closed
    ]
begin

tts_lemma Inf_UNIV: "ow U = ow"
    is complete_lattice_class.Inf_UNIV.

tts_lemma Sup_UNIV: "ow U = ow"
    is complete_lattice_class.Sup_UNIV.

end

context 
  fixes U2 :: "'b set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='b]

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (insert Sup_least, auto)
begin

tts_lemma SUP_upper2:
  assumes "A  U2"
    and "u  U"
    and "xU2. f x  U"
    and "i  A"
    and "u ow f i"
  shows "u ow ow (f ` A)"
  is complete_lattice_class.SUP_upper2.

tts_lemma INF_lower2:
  assumes "A  U2"
    and "xU2. f x  U"
    and "u  U"
    and "i  A"
    and "f i ow u"
  shows "ow (f ` A) ow u"
  is complete_lattice_class.INF_lower2.
    
tts_lemma less_INF_D:
  assumes "y  U"
    and "xU2. f x  U"
    and "A  U2"
    and "y <ow ow (f ` A)"
    and "i  A"
  shows "y <ow f i"
  is complete_lattice_class.less_INF_D.
    
tts_lemma SUP_lessD:
  assumes "xU2. f x  U"
    and "A  U2"
    and "y  U"
    and "ow (f ` A) <ow y"
    and "i  A"
  shows "f i <ow y"
  is complete_lattice_class.SUP_lessD.

tts_lemma SUP_le_iff:
  assumes "xU2. f x  U" and "A  U2" and "u  U"
  shows "(ow (f ` A) ow u) = (xA. f x ow u)"
    is complete_lattice_class.SUP_le_iff.

end

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (auto dest: top_le)
begin

tts_lemma INF_eqI:
  assumes "A  U2"
    and "x  U"
    and "xU2. f x  U"
    and "i. i  U2; i  A  x ow f i"
    and "y. y  U; i. i  U2; i  A  y ow f i  y ow x"
  shows "ow (f ` A) = x"
  is complete_lattice_class.INF_eqI.

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (auto simp: sup_bot.eq_iff)
begin

tts_lemma SUP_eqI:
  assumes "A  U2"
    and "xU2. f x  U"
    and "x  U"
    and "i. i  U2; i  A  f i ow x"
    and "y. y  U; i. i  U2; i  A  f i ow y  x ow y"
  shows "ow (f ` A) = x"
    is complete_lattice_class.SUP_eqI.
    
end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_le_SUP:
  assumes "A  U2" and "xU2. f x  U" and "A  {}"
  shows "ow (f ` A) ow ow (f ` A)"
  is complete_lattice_class.INF_le_SUP.
    
tts_lemma INF_inf_const1:
  assumes "I  U2" and "x  U" and "xU2. f x  U" and "I  {}"
  shows "ow ((λi. x ow f i) ` I) = x ow ow (f ` I)"
    is complete_lattice_class.INF_inf_const1.
    
tts_lemma INF_inf_const2:
  assumes "I  U2" and "xU2. f x  U" and "x  U" and "I  {}"
  shows "ow ((λi. f i ow x) ` I) = ow (f ` I) ow x"
    is complete_lattice_class.INF_inf_const2.    

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through auto
begin

tts_lemma INF_eq_const:
  assumes "I  U2" 
    and "xU2. f x  U" 
    and "I  {}"
    and "i. i  I  f i = x"
  shows "ow (f ` I) = x"
    given complete_lattice_class.INF_eq_const
proof-
  assume 
    "I  U2; xU2. f x  U; I  {}; i. i  U2; i  I  f i = x  
      ow (f ` I) = x"
    for I :: "'a set" and U2 f x
  then have 
    "I  U2; xU2. f x  U; I  {}; i. i  I  f i = x  
      ow (f ` I) = x"
    by presburger
  then show "ow (f ` I) = x" using assms by simp
qed
    
tts_lemma SUP_eq_const:
  assumes "I  U2"
    and "xU2. f x  U"
    and "I  {}"
    and "i. i  I  f i = x"
  shows "ow (f ` I) = x"
    given complete_lattice_class.SUP_eq_const
proof-
  assume 
    "I  U2; xU2. f x  U; I  {}; i. i  U2; i  I  f i = x  
      ow (f ` I) = x"
    for I :: "'a set" and U2 f x
  then have 
    "I  U2; xU2. f x  U; I  {}; i. i  I  f i = x  
      ow (f ` I) = x"
    by presburger
  then show "ow (f ` I) = x" using assms by simp
qed
    
tts_lemma SUP_eq_iff:
  assumes "I  U2"
    and "c  U"
    and "xU2. f x  U"
    and "I  {}"
    and "i. i  I  c ow f i"
  shows "(ow (f ` I) = c) = (xI. f x = c)"
    given complete_lattice_class.SUP_eq_iff
proof-
  assume 
    "
      I  U2; 
      c  U; xU2. f x  U; 
      I  {}; 
      i. i  U2; i  I  c ow f i
       (ow (f ` I) = c) = (xI. f x = c)"
    for I :: "'a set" and U2 c f
  then have 
    "
      I  U2; 
      c  U; xU2. f x  U; 
      I  {}; 
      i. i  I  c ow f i
      (ow (f ` I) = c) = (xI. f x = c)"
    by presburger
  then show "(ow (f ` I) = c) = (xI. f x = c)" using assms by auto
qed
    
tts_lemma INF_eq_iff:
  assumes "I  U2"
    and "xU2. f x  U"
    and "c  U"
    and "I  {}"
    and "i. i  I  f i ow c"
  shows "(ow (f ` I) = c) = (xI. f x = c)"
    given complete_lattice_class.INF_eq_iff
proof-
  assume 
    "
      I  U2; 
      xU2. f x  U; c  U; 
      I  {}; 
      i. i  U2; i  I  f i ow c
      (ow (f ` I) = c) = (xI. f x = c)"
    for I :: "'a set" and U2 f c
  then have 
    "
      I  U2; 
      xU2. f x  U; c  U; 
      I  {}; 
      i. i  I  f i ow c
      (ow (f ` I) = c) = (xI. f x = c)"
    by presburger
  then show "(ow (f ` I) = c) = (xI. f x = c)" using assms by auto
qed

end


context 
  fixes U2 :: "'b set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='b]

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through (auto simp: sup_bot.top_unique top_le intro: Sup_least)
begin

tts_lemma INF_insert:
  assumes "xU2. f x  U" and "a  U2" and "A  U2"
  shows "ow (f ` insert a A) = f a ow ow (f ` A)"
  is complete_lattice_class.INF_insert.
    
tts_lemma SUP_insert:
  assumes "xU2. f x  U" and "a  U2" and "A  U2"
  shows "ow (f ` insert a A) = f a ow ow (f ` A)"
    is complete_lattice_class.SUP_insert.
    
tts_lemma le_INF_iff:
  assumes "u  U" and "xU2. f x  U" and "A  U2"
  shows "(u ow ow (f ` A)) = (xA. u ow f x)"
  is complete_lattice_class.le_INF_iff.
    
tts_lemma INF_union:
  assumes "xU2. M x  U" and "A  U2" and "B  U2"
  shows "ow (M ` (A  B)) = ow (M ` A) ow ow (M ` B)"
    is complete_lattice_class.INF_union.
    
tts_lemma SUP_union:
  assumes "xU2. M x  U" and "A  U2" and "B  U2"
  shows "ow (M ` (A  B)) = ow (M ` A) ow ow (M ` B)"
  is complete_lattice_class.SUP_union.
    
tts_lemma SUP_bot_conv:
  assumes "xU2. B x  U" and "A  U2"
  shows 
    "(ow (B ` A) = ow) = (xA. B x = ow)"
    "(ow = ow (B ` A)) = (xA. B x = ow)"
  is complete_lattice_class.SUP_bot_conv.
    
tts_lemma INF_top_conv:
  assumes "xU2. B x  U" and "A  U2"
  shows 
    "(ow (B ` A) = ow) = (xA. B x = ow)"
    "(ow = ow (B ` A)) = (xA. B x = ow)"
  is complete_lattice_class.INF_top_conv.
    
tts_lemma SUP_upper:
  assumes "A  U2" and "xU2. f x  U" and "i  A"
  shows "f i ow ow (f ` A)"
  is complete_lattice_class.SUP_upper.
    
tts_lemma INF_lower:
  assumes "A  U2" and "xU2. f x  U" and "i  A"
  shows "ow (f ` A) ow f i"
  is complete_lattice_class.INF_lower.

tts_lemma INF_inf_distrib:
  assumes "xU2. f x  U" and "A  U2" and "xU2. g x  U"
  shows "ow (f ` A) ow ow (g ` A) = ow ((λa. f a ow g a) ` A)"
    is complete_lattice_class.INF_inf_distrib.

tts_lemma SUP_sup_distrib:
  assumes "xU2. f x  U" and "A  U2" and "xU2. g x  U"
  shows "ow (f ` A) ow ow (g ` A) = ow ((λa. f a ow g a) ` A)"
    is complete_lattice_class.SUP_sup_distrib.

tts_lemma SUP_subset_mono:
  assumes "B  U2"
    and "xU2. f x  U"
    and "xU2. g x  U"
    and "A  B"
    and "x. x  A  f x ow g x"
  shows "ow (f ` A) ow ow (g ` B)"
    given complete_lattice_class.SUP_subset_mono
proof-
  assume 
    "
      B  U2; 
      xU2. f x  U; 
      xU2. g x  U; 
      A  B; 
      x. x  U2; x  A  f x ow g x
      ow (f ` A) ow ow (g ` B)"
    for B :: "'b set" and f g A
  then have
    "
      B  U2; 
      xU2. f x  U; 
      xU2. g x  U; 
      A  B; 
      x. x  A  f x ow g x
      ow (f ` A) ow ow (g ` B)"
    by auto
  then show "ow (f ` A) ow ow (g ` B)" using assms by blast
qed

tts_lemma INF_superset_mono:
  assumes "A  U2"
    and "xU2. f x  U"
    and "xU2. g x  U"
    and "B  A"
    and "x. x  U2; x  B  f x ow g x"
  shows "ow (f ` A) ow ow (g ` B)"
    given complete_lattice_class.INF_superset_mono
proof-
  assume 
    "
      A  U2; 
      xU2. f x  U; 
      xU2. g x  U; 
      B  A; 
      x. x  U2; x  B  f x ow g x
      ow (f ` A) ow ow (g ` B)"
    for A :: "'b set" and f g B
  then have
    "
      A  U2; 
      xU2. f x  U; 
      xU2. g x  U; 
      B  A; 
      x. x  B  f x ow g x
      ow (f ` A) ow ow (g ` B)"
    by auto
  then show "ow (f ` A) ow ow (g ` B)" using assms by blast
qed

tts_lemma INF_absorb:
  assumes "I  U2" and "xU2. A x  U" and "k  I"
  shows "A k ow ow (A ` I) = ow (A ` I)"
    is complete_lattice_class.INF_absorb.

tts_lemma SUP_absorb:
  assumes "I  U2" and "xU2. A x  U" and "k  I"
  shows "A k ow ow (A ` I) = ow (A ` I)"
    is complete_lattice_class.SUP_absorb.

end

end

context 
  fixes f :: "'b  'al" and U2 :: "'b set"
  assumes f[transfer_rule]: "x  U2. f x = ow"
begin

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  sbterms: (‹Orderings.bot::?'a::complete_lattice› to ow)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma SUP_bot:
  assumes "A  U2"
  shows "ow (f ` A) = ow"
    is complete_lattice_class.SUP_bot[folded const_fun_def].

end

end

context 
  fixes f :: "'b  'al" and U2 :: "'b set"
  assumes f[transfer_rule]: "x  U2. f x = ow"
begin

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  sbterms: (‹Orderings.top::?'a::complete_lattice› to ow)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_top:
  assumes "A  U2"
  shows "ow (f ` A) = ow"
  is complete_lattice_class.INF_top[folded const_fun_def].

end

end

context 
  fixes f :: "'b  'al" and c and F and U2 :: "'b set"
  assumes c_closed[transfer_rule]: "c  U"
  assumes f[transfer_rule]: "x  U2. f x = c"
begin

tts_register_sbts c | U
proof-
  assume ALC: "Domainp ALC = (λx. x  U)" 
  have "Domainp ALC c" unfolding ALC by (simp add: c_closed)
  then obtain c' where "ALC c c'" by blast
  then show "c'. ALC c c'" by auto
qed

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  sbterms: (?c::?'a::complete_lattice› to c)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_constant:
  assumes "A  U2"
  shows "ow (f ` A) = (if A = {} then ow else c)"
    is complete_lattice_class.INF_constant[folded const_fun_def].

tts_lemma SUP_constant:
  assumes "A  U2"
  shows "ow (f ` A) = (if A = {} then ow else c)"
    is complete_lattice_class.SUP_constant[folded const_fun_def].

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  sbterms: (?f::?'a::complete_lattice› to c)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  eliminating through simp
begin

tts_lemma INF_const:
  assumes "A  U2" and "A  {}"
  shows "ow ((λi. c) ` A) = c"
    is complete_lattice_class.INF_const.
    
tts_lemma SUP_const:
  assumes "A  U2" and "A  {}"
  shows "ow ((λi. c) ` A) = c"
    is complete_lattice_class.SUP_const.

end

end

end

context complete_lattice_ow
begin

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›) and (?'c to U3::'c set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty  
  eliminating ?U  {} through (force simp: subset_iff INF_top equals0D)
  applying [
    OF Inf_closed' Sup_closed' inf_closed' sup_closed' bot_closed top_closed
    ]
begin

tts_lemma SUP_eq:
  assumes "A  U2"
    and "B  U3"
    and "xU2. f (x::'a)  U"
    and "xU3. g x  U"
    and "i. i  A  xB. f i ow g x"
    and "j. j  B  xA. g j ow f x"
  shows "ow (f ` A) = ow (g ` B)"
    given complete_lattice_class.SUP_eq
proof-
  assume 
    "
      A  U2; 
      B  U3; 
      xU2. f x  U; 
      xU3. g x  U; 
      i. i  U2; i  A  xB. f i ow g x; 
      j. j  U3; j  B  xA. g j ow f x
      ow (f ` A) = ow (g ` B)"
    for A :: "'a set" and U2 and B :: "'b set" and U3 f g
  then have
    "
      A  U2; 
      B  U3; 
      xU2. f x  U; 
      xU3. g x  U; 
      i. i  A  xB. f i ow g x; 
      j. j  B  xA. g j ow f x
      ow (f ` A) = ow (g ` B)"
    by simp
  then show "ow (f ` A) = ow (g ` B)" using assms by simp
qed

tts_lemma INF_eq:
  assumes "A  U2"
    and "B  U3"
    and "xU3. g x  U"
    and "xU2. f (x::'a)  U"
    and "i. i  A  xB. g x ow f i"
    and "j. j  B  xA. f x ow g j"
  shows "ow (f ` A) = ow (g ` B)"
    given complete_lattice_class.INF_eq
proof-
  assume 
    "
      A  U2; 
      B  U3; 
      xU3. g x  U; 
      xU2. f x  U; 
      i. i  U2; i  A  xB. g x ow f i; 
      j. j  U3; j  B  xA. f x ow g j
      ow (f ` A) = ow (g ` B)"
    for A :: "'a set" and U2 and B :: "'b set" and U3 g f
  then have
    "
      A  U2; 
      B  U3; 
      xU3. g x  U; 
      xU2. f x  U; 
      i. i  A  xB. g x ow f i; 
      j. j  B  xA. f x ow g j
      ow (f ` A) = ow (g ` B)"
    by simp
  then show "ow (f ` A) = ow (g ` B)" using assms by simp
qed

end

end

context complete_lattice_ow
begin

context 
  fixes U2 :: "'b set" and U3 :: "'c set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='b]
  image_transfer[where ?'a='c]

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›) and (?'c to U3::'c set›)
  rewriting ctr_simps
  substituting complete_lattice_ow_axioms and sup_bot.sl_neut.not_empty
  applying [
    OF _ _ Inf_closed' Sup_closed' inf_closed' sup_closed' bot_closed top_closed
    ]
begin

tts_lemma ne_INF_commute:
  assumes "U2  {}"
    and "U3  {}"
    and "xU2. yU3. f (x::'b) y  U"
    and "B  U3"
    and "A  U2"
  shows "ow ((λi. ow (f i ` B)) ` A) = ow ((λj. ow ((λi. f i j) ` A)) ` B)"
    is complete_lattice_class.INF_commute.
    
tts_lemma ne_SUP_commute:
  assumes "U2  {}"
    and "U3  {}"
    and "xU2. yU3. f (x::'b) y  U"
    and "B  U3"
    and "A  U2"
  shows "ow ((λi. ow (f i ` B)) ` A) = ow ((λj. ow ((λi. f i j) ` A)) ` B)"
    is complete_lattice_class.SUP_commute.
    
tts_lemma ne_SUP_mono:
  assumes "U2  {}"
    and "U3  {}"
    and "A  U2"
    and "B  U3"
    and "xU2. f (x::'b)  U"
    and "xU3. g x  U"
    and "n. n  U2; n  A  xB. f n ow g x"
  shows "ow (f ` A) ow ow (g ` B)"
    is complete_lattice_class.SUP_mono.
    
tts_lemma ne_INF_mono:
  assumes "U2  {}"
    and "U3  {}"
    and "B  U2"
    and "A  U3"
    and "xU3. f x  U"
    and "xU2. g (x::'b)  U"
    and "m. m  U2; m  B  xA. f x ow g m"
  shows "ow (f ` A) ow ow (g ` B)"
    is complete_lattice_class.INF_mono.

end

end

lemma INF_commute:
  assumes "xU2. yU3. f x y  U" and "B  U3" and "A  U2" 
  shows 
    "ow ((λx. ow (f x ` B)) ` A) = ow ((λj. ow ((λi. f i j) ` A)) ` B)"
proof(cases U2 = {})
  case True then show ?thesis 
    using assms by (simp add: inf_top.sl_neut.neutral_map Inf_top_conv(2)) 
next
  case ne_U2: False show ?thesis
  proof(cases U3 = {})
    case True show ?thesis
    proof-
      from assms(2) have "B = {}" unfolding True by simp
      from assms(1) show ?thesis 
        unfolding B = {} by (force intro: INF_top)
    qed
  next
    case False 
    from ne_U2 False assms show ?thesis by (rule ne_INF_commute)
  qed
qed

lemma SUP_commute:
  assumes "xU2. yU3. f x y  U" and "B  U3" and "A  U2"
  shows 
    "ow ((λx. ow (f x ` B)) ` A) = ow ((λj. ow ((λi. f i j) ` A)) ` B)"
proof(cases U2 = {})
  case True show ?thesis
  proof-
    from assms(3) have "A = {}" unfolding True by simp
    from assms(2) show ?thesis 
      unfolding A = {} 
      by (simp add: sup_bot.sl_neut.neutral_map inf_absorb1 SUP_bot)
  qed
next
  case ne_U2: False show ?thesis
  proof(cases U3 = {})
    case True show ?thesis
    proof-
      from assms(2) have "B = {}" unfolding True by simp
      from assms(1) show ?thesis 
        unfolding B = {} 
        by (simp add: sup_bot.sl_neut.neutral_map Sup_bot_conv(1))
    qed
  next
    case False 
    from ne_U2 False assms show ?thesis by (rule ne_SUP_commute)
  qed
qed

lemma SUP_mono:
  assumes "A  U2" 
    and "B  U3" 
    and "xU2. f x  U" 
    and "xU3. g x  U"
    and "n. n  A  mB. f n ow g m" 
  shows "ow (f ` A) ow ow (g ` B)"
proof(cases U2 = {})
  case True show ?thesis
  proof-
    from assms(1) have "A = {}" unfolding True by simp
    have "f ` A = {}" unfolding A = {} by simp
    from assms(2,4) show ?thesis 
      unfolding f ` A = {} by (simp add: image_subset_iff in_mono)
  qed
next
  case ne_U2: False show ?thesis
  proof(cases U3 = {})
    case True show ?thesis
    proof-
      from assms(2) have "B = {}" unfolding True by simp
      have "g ` B = {}" unfolding B = {} by simp
      from assms(1,3,5) show ?thesis
        unfolding g ` B = {} B = {} by (force simp: subset_iff)
    qed
  next
    case False 
    from ne_U2 False assms show ?thesis by (rule ne_SUP_mono)
  qed
qed

lemma INF_mono:
  assumes "B  U2" 
    and "A  U3" 
    and "xU3. f x  U" 
    and "xU2. g x  U"
    and "m. m  B  nA. f n ow g m" 
  shows "ow (f ` A) ow ow (g ` B)"
proof(cases U2 = {})
  case True show ?thesis
  proof-
    from assms(1) have "B = {}" unfolding True by simp
    have "g ` B = {}" unfolding B = {} by simp
    from assms(2,3) show ?thesis 
      unfolding g ` B = {} by (simp add: image_subset_iff in_mono)
  qed
next
  case ne_U2: False show ?thesis
  proof(cases U3 = {})
    case True show ?thesis
    proof-
      from assms(2) have "A = {}" unfolding True by simp
      have "f ` A = {}" unfolding A = {} by simp
      from assms show ?thesis
        unfolding f ` A = {} A = {} by (auto simp: subset_iff) fastforce
    qed
  next
    case False from ne_U2 False assms show ?thesis by (rule ne_INF_mono)
  qed                                                              
qed

end

context complete_lattice_pair_ow
begin

tts_context
  tts: (?'a to U1) and (?'b to U2) 
  rewriting ctr_simps
  substituting cl1.complete_lattice_ow_axioms
    and cl2.complete_lattice_ow_axioms
    and cl1.inf_top.sl_neut.not_empty
    and cl2.inf_top.sl_neut.not_empty
  applying 
    [
      OF 
        cl1.Inf_closed' 
        cl1.Sup_closed' 
        cl1.inf_closed'   
        cl1.sup_closed'
        cl1.bot_closed
        cl1.top_closed
        cl2.Inf_closed' 
        cl2.Sup_closed' 
        cl2.inf_closed'   
        cl2.sup_closed'
        cl2.bot_closed
        cl2.top_closed
    ]
begin

tts_lemma mono_Inf:
  assumes "xU1. f x  U2"
    and "A  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
  shows "f (ow.1 A) ow.2 ow.2 (f ` A)"
    is complete_lattice_class.mono_Inf.
    
tts_lemma mono_Sup:
  assumes "xU1. f x  U2"
    and "A  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
  shows "ow.2 (f ` A) ow.2 f (ow.1 A)"
    is complete_lattice_class.mono_Sup.

end

context 
  fixes U3 :: "'c set"
begin

lemmas [transfer_rule] =
  image_transfer[where ?'a='c]

tts_context
  tts: (?'a to U1) and (?'b to U2) and (?'c to U3::'c set›) 
  rewriting ctr_simps
  substituting cl1.complete_lattice_ow_axioms
    and cl2.complete_lattice_ow_axioms
    and cl1.inf_top.sl_neut.not_empty
    and cl2.inf_top.sl_neut.not_empty
  eliminating through (simp add: image_subset_iff image_subset_iff')
  applying 
    [
      OF 
        _
        cl1.Inf_closed' 
        cl1.Sup_closed' 
        cl1.inf_closed'   
        cl1.sup_closed'
        cl1.bot_closed
        cl1.top_closed
        cl2.Inf_closed' 
        cl2.Sup_closed' 
        cl2.inf_closed'   
        cl2.sup_closed'
        cl2.bot_closed
        cl2.top_closed
    ]
begin

tts_lemma mono_SUP:
  assumes "U3  {}"
    and "xU1. f x  U2"
    and "xU3. A x  U1"
    and "I  U3"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
  shows "ow.2 ((λx. f (A x)) ` I) ow.2 f (ow.1 (A ` I))"
    is complete_lattice_class.mono_SUP.
    
tts_lemma mono_INF:
  assumes "U3  {}"
    and "xU1. f x  U2"
    and "xU3. A x  U1"
    and "I  U3"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
  shows "f (ow.1 (A ` I)) ow.2 ow.2 ((λx. f (A x)) ` I)"
    is complete_lattice_class.mono_INF.
    
end

end

end

text‹\newpage›

end

Theory SML_Linorders

(* Title: Examples/SML_Relativization/Lattices/SML_Linorders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about linear orders›
theory SML_Linorders
  imports SML_Semilattices
begin               



subsection‹Linear orders›


subsubsection‹Definitions and further properties›

locale linorder_ow = order_ow +
  assumes linear: " x  U; y  U   x ow y  y ow x"
begin

sublocale min: 
  semilattice_order_ow U (λx y. (with (≤ow) : «min» x y)) (≤ow) (<ow)
  apply unfold_locales
  subgoal unfolding min.with_def by simp
  subgoal by (metis linear order_trans min.with_def)
  subgoal unfolding min.with_def by (auto dest: linear simp: antisym)
  subgoal unfolding min.with_def by simp
  subgoal unfolding min.with_def by (simp add: eq_iff)
  subgoal unfolding min.with_def by (simp add: less_le)
  done             

sublocale max: 
  semilattice_order_ow U (λx y. (with (≤ow) : «max» x y)) (≥ow) (>ow)
  apply unfold_locales
  subgoal unfolding max.with_def by simp
  subgoal by (metis linear order_trans max.with_def)
  subgoal unfolding max.with_def by (auto dest: linear simp: antisym)
  subgoal unfolding max.with_def by simp
  subgoal unfolding max.with_def by (auto dest: linear simp: antisym)
  subgoal unfolding max.with_def by (auto dest: linear simp: less_le_not_le)
  done

end

locale ord_linorder_ow = 
  ord?: ord_ow U1 le1 ls1 + lo?: linorder_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2
begin

sublocale ord_order_ow ..

end

locale preorder_linorder_ow = 
  po?: preorder_ow U1 le1 ls1 + lo?: linorder_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2
begin

sublocale preorder_order_ow ..

end

locale order_linorder_ow = 
  order?: order_ow U1 le1 ls1 + lo?: linorder_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2
begin

sublocale order_pair_ow ..

end

locale linorder_pair_ow = 
  lo1?: linorder_ow U1 le1 ls1 + lo2?: linorder_ow U2 le2 ls2
  for U1 :: "'ao set" and le1 ls1 and U2 :: "'bo set" and le2 ls2
begin

sublocale order_linorder_ow ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma linorder_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      (linorder_ow (Collect (Domainp A))) class.linorder"
  unfolding 
    linorder_ow_def class.linorder_def
    linorder_ow_axioms_def class.linorder_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp
  
end


subsubsection‹Relativization›

context linorder_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting linorder_ow_axioms
  eliminating through simp
begin

tts_lemma le_less_linear:
  assumes "x  U" and "y  U"
  shows "x ow y  y <ow x"
  is linorder_class.le_less_linear.

tts_lemma not_less:
  assumes "x  U" and "y  U"
  shows "(¬ x <ow y) = (y ow x)"
    is linorder_class.not_less.
    
tts_lemma not_le:
  assumes "x  U" and "y  U"
  shows "(¬ x ow y) = (y <ow x)"
    is linorder_class.not_le.

tts_lemma lessThan_minus_lessThan:
  assumes "n  U" and "m  U"
  shows "{..<own} - {..<owm} = (on U with (≤ow) (<ow) : {m..<n})"
    is linorder_class.lessThan_minus_lessThan.

tts_lemma Ici_subset_Ioi_iff:
  assumes "a  U" and "b  U"
  shows "({a..ow}  {b<ow..}) = (b <ow a)"
    is linorder_class.Ici_subset_Ioi_iff.

tts_lemma Iic_subset_Iio_iff:
  assumes "a  U" and "b  U"
  shows "({..owa}  {..<owb}) = (a <ow b)"
    is linorder_class.Iic_subset_Iio_iff.

tts_lemma leI:
  assumes "x  U" and "y  U" and "¬ x <ow y"
  shows "y ow x"
    is linorder_class.leI.

tts_lemma not_le_imp_less:
  assumes "y  U" and "x  U" and "¬ y ow x"
  shows "x <ow y"
    is linorder_class.not_le_imp_less.

tts_lemma Int_atMost:
  assumes "a  U" and "b  U"
  shows "{..owa}  {..owb} = {..owmin a b}"
    is linorder_class.Int_atMost.

tts_lemma lessThan_Int_lessThan:
  assumes "a  U" and "b  U"
  shows "{a<ow..}  {b<ow..} = {max a b<ow..}"
    is linorder_class.lessThan_Int_lessThan.

tts_lemma greaterThan_Int_greaterThan:
  assumes "a  U" and "b  U"
  shows "{..<owa}  {..<owb} = {..<owmin a b}"
    is linorder_class.greaterThan_Int_greaterThan.

tts_lemma less_linear:
  assumes "x  U" and "y  U"
  shows "x <ow y  x = y  y <ow x"
    is linorder_class.less_linear.

tts_lemma Int_atLeastAtMostR2:
  assumes "a  U" and "c  U" and "d  U"
  shows "{a..ow}  {c..owd} = {max a c..owd}"
    is linorder_class.Int_atLeastAtMostR2.

tts_lemma Int_atLeastAtMostR1:
  assumes "b  U" and "c  U" and "d  U"
  shows "{..owb}  {c..owd} = {c..owmin b d}"
    is linorder_class.Int_atLeastAtMostR1.

tts_lemma Int_atLeastAtMostL2:
  assumes "a  U" and "b  U" and "c  U"
  shows "{a..owb}  {c..ow} = {max a c..owb}"
    is linorder_class.Int_atLeastAtMostL2.

tts_lemma Int_atLeastAtMostL1:
  assumes "a  U" and "b  U" and "d  U"
  shows "{a..owb}  {..owd} = {a..owmin b d}"
    is linorder_class.Int_atLeastAtMostL1.

tts_lemma neq_iff:
  assumes "x  U" and "y  U"
  shows "(x  y) = (x <ow y  y <ow x)"
    is linorder_class.neq_iff.

tts_lemma not_less_iff_gr_or_eq:
  assumes "x  U" and "y  U"
  shows "(¬ x <ow y) = (y <ow x  x = y)"
    is linorder_class.not_less_iff_gr_or_eq.

tts_lemma max_min_distrib2:
  assumes "a  U" and "b  U" and "c  U"
  shows "max a (min b c) = min (max a b) (max a c)"
    is linorder_class.max_min_distrib2.

tts_lemma max_min_distrib1:
  assumes "b  U" and "c  U" and "a  U"
  shows "max (min b c) a = min (max b a) (max c a)"
    is linorder_class.max_min_distrib1.

tts_lemma min_max_distrib2:
  assumes "a  U" and "b  U" and "c  U"
  shows "min a (max b c) = max (min a b) (min a c)"
    is linorder_class.min_max_distrib2.

tts_lemma min_max_distrib1:
  assumes "b  U" and "c  U" and "a  U"
  shows "min (max b c) a = max (min b a) (min c a)"
    is linorder_class.min_max_distrib1.

tts_lemma atLeastAtMost_diff_ends:
  assumes "a  U" and "b  U"
  shows "{a..owb} - {a, b} = {a<ow..<owb}"
    is linorder_class.atLeastAtMost_diff_ends.

tts_lemma less_max_iff_disj:
  assumes "z  U" and "x  U" and "y  U"
  shows "(z <ow max x y) = (z <ow x  z <ow y)"
    is linorder_class.less_max_iff_disj.

tts_lemma min_less_iff_conj:
  assumes "z  U" and "x  U" and "y  U"
  shows "(z <ow min x y) = (z <ow x  z <ow y)"
    is linorder_class.min_less_iff_conj.

tts_lemma max_less_iff_conj:
  assumes "x  U" and "y  U" and "z  U"
  shows "(max x y <ow z) = (x <ow z  y <ow z)"
    is linorder_class.max_less_iff_conj.

tts_lemma min_less_iff_disj:
  assumes "x  U" and "y  U" and "z  U"
  shows "(min x y <ow z) = (x <ow z  y <ow z)"
    is linorder_class.min_less_iff_disj.

tts_lemma le_max_iff_disj:
  assumes "z  U" and "x  U" and "y  U"
  shows "(z ow max x y) = (z ow x  z ow y)"
    is linorder_class.le_max_iff_disj.

tts_lemma min_le_iff_disj:
  assumes "x  U" and "y  U" and "z  U"
  shows "(min x y ow z) = (x ow z  y ow z)"
    is linorder_class.min_le_iff_disj.

tts_lemma antisym_conv3:
  assumes "y  U" and "x  U" and "¬ y <ow x"
  shows "(¬ x <ow y) = (x = y)"
    is linorder_class.antisym_conv3.

tts_lemma Int_atLeastAtMost:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "{a..owb}  {c..owd} = {max a c..owmin b d}"
    is linorder_class.Int_atLeastAtMost.

tts_lemma Int_atLeastLessThan:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows 
    "(on U with (≤ow) (<ow) : {a..<b})  (on U with (≤ow) (<ow) : {c..<d}) = 
      (on U with (≤ow) (<ow) : {(max a c)..<(min b d)})"
    is linorder_class.Int_atLeastLessThan.

tts_lemma Int_greaterThanAtMost:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "{a<ow..b}  {c<ow..d} = {max a c<ow..min b d}"
    is linorder_class.Int_greaterThanAtMost.

tts_lemma Int_greaterThanLessThan:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "{a<ow..<owb}  {c<ow..<owd} = {max a c<ow..<owmin b d}"
    is linorder_class.Int_greaterThanLessThan.

tts_lemma le_cases:
  assumes "x  U" and "y  U" and "x ow y  P" and "y ow x  P"
  shows P
    is linorder_class.le_cases.

tts_lemma split_max:
  assumes "i  U" and "j  U"
  shows "P (max i j) = ((i ow j  P j)  (¬ i ow j  P i))"
    is linorder_class.split_max.

tts_lemma split_min:
  assumes "i  U" and "j  U"
  shows "P (min i j) = ((i ow j  P i)  (¬ i ow j  P j))"
    is linorder_class.split_min.

tts_lemma Ioc_subset_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a<ow..b}  {c<ow..d}) = (b ow a  b ow d  c ow a)"
    is linorder_class.Ioc_subset_iff.

tts_lemma atLeastLessThan_subset_iff:
  assumes "a  U"
    and "b  U"
    and "c  U"
    and "d  U"
    and "(on U with (≤ow) (<ow) : {a..<b})  (on U with (≤ow) (<ow) : {c..<d})"
  shows "b ow a  b ow d  c ow a"
    is linorder_class.atLeastLessThan_subset_iff.

tts_lemma Ioc_inj:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a<ow..b} = {c<ow..d}) = (b ow a  d ow c  a = c  b = d)"
    is linorder_class.Ioc_inj.

tts_lemma neqE:
  assumes "x  U"
    and "y  U"
    and "x  y"
    and "x <ow y  R"
    and "y <ow x  R"
  shows R
    is linorder_class.neqE.

tts_lemma Ioc_disjoint:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows 
    "({a<ow..b}  {c<ow..d} = {}) = (b ow a  d ow c  b ow c  d ow a)"
    is linorder_class.Ioc_disjoint.

tts_lemma linorder_cases:
  assumes "x  U"
    and "y  U"
    and "x <ow y  P"
    and "x = y  P"
    and "y <ow x  P"
  shows P
    is linorder_class.linorder_cases.

tts_lemma le_cases3:
  assumes "x  U"
    and "y  U"
    and "z  U"
    and "x ow y; y ow z  P"
    and "y ow x; x ow z  P"
    and "x ow z; z ow y  P"
    and "z ow y; y ow x  P"
    and "y ow z; z ow x  P"
    and "z ow x; x ow y  P"
  shows P
    is linorder_class.le_cases3.

end

end

context order_linorder_ow
begin

tts_context
  tts: (?'a to U2) and (?'b to U1)
  rewriting ctr_simps
  substituting order.order_ow_axioms and lo.linorder_ow_axioms
  eliminating through simp
begin


tts_lemma strict_mono_imp_inj_on:
  assumes "xU2. f x  U1"
    and "A  U2"
    and "on U2 with (<ow.1) (<ow.2) : «strict_mono» f"
  shows "inj_on f A"
    is linorder_class.strict_mono_imp_inj_on.
    
tts_lemma strict_mono_eq:
  assumes "xU2. f x  U1"
    and "x  U2"
    and "y  U2"
    and "on U2 with (<ow.1) (<ow.2) : «strict_mono» f"
  shows "(f x = f y) = (x = y)"
    is linorder_class.strict_mono_eq.

tts_lemma strict_mono_less:
  assumes "xU2. f x  U1"
    and "x  U2"
    and "y  U2"
    and "on U2 with (<ow.1) (<ow.2) : «strict_mono» f"
  shows "(f x <ow.1 f y) = (x <ow.2 y)"
    is linorder_class.strict_mono_less.
    
tts_lemma strict_mono_less_eq:
  assumes "xU2. f x  U1"
    and "x  U2"
    and "y  U2"
    and "on U2 with (<ow.1) (<ow.2) : «strict_mono» f"
  shows "(f x ow.1 f y) = (x ow.2 y)"
    is linorder_class.strict_mono_less_eq.
    
tts_lemma mono_strict_invE:
  assumes "xU2. f x  U1"
    and "x  U2"
    and "y  U2"
    and "on U2 with (≤ow.1) (≤ow.2) : «mono» f"
    and "f x <ow.1 f y"
    and "x <ow.2 y  thesis"
  shows thesis
    is linorder_class.mono_strict_invE.

tts_lemma mono_invE:
  assumes "xU2. f x  U1"
    and "x  U2"
    and "y  U2"
    and "on U2 with (≤ow.1) (≤ow.2) : «mono» f"
    and "f x <ow.1 f y"
    and "x ow.2 y  thesis"
  shows thesis
    is linorder_class.mono_invE.

end
    
end

context linorder_pair_ow
begin

tts_context
  tts: (?'a to U1) and (?'b to U2)
  rewriting ctr_simps
  substituting lo1.linorder_ow_axioms and lo2.linorder_ow_axioms
  eliminating through simp
begin

tts_lemma max_of_mono:
  assumes "xU1. f x  U2"
    and "m  U1"
    and "n  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
  shows "lo2.max (f m) (f n) = f (lo1.max m n)"
    is linorder_class.max_of_mono.

tts_lemma min_of_mono:
  assumes "xU1. f x  U2"
    and "m  U1"
    and "n  U1"
    and "on U1 with (≤ow.2) (≤ow.1) : «mono» f"
  shows "lo2.min (f m) (f n) = f (lo1.min m n)"
    is linorder_class.min_of_mono.

end

end



subsection‹Dense linear orders›


subsubsection‹Definitions and further properties›

locale dense_linorder_ow = linorder_ow U le ls + dense_order_ow U le ls
  for U :: "'ao set" and le (infix ow 50) and ls (infix <ow 50)


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma dense_linorder_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((A ===> A ===> (=)) ===> (A ===> A ===> (=))  ===> (=)) 
      (dense_linorder_ow (Collect (Domainp A))) class.dense_linorder"
  unfolding dense_linorder_ow_def class.dense_linorder_def
  apply transfer_prover_start
  apply transfer_step+
  by auto

end


subsubsection‹Relativization›

context dense_linorder_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting dense_linorder_ow_axioms
  eliminating through simp
begin

tts_lemma infinite_Icc:
  assumes "a  U" and "b  U" and "a <ow b"
  shows "infinite {a..owb}"
    is dense_linorder_class.infinite_Icc.

tts_lemma infinite_Ico:
  assumes "a  U" and "b  U" and "a <ow b"
  shows "infinite (on U with (≤ow) (<ow) : {a..<b})"
    is dense_linorder_class.infinite_Ico.

tts_lemma infinite_Ioc:
  assumes "a  U" and "b  U" and "a <ow b"
  shows "infinite {a<ow..b}"
    is dense_linorder_class.infinite_Ioc.

tts_lemma infinite_Ioo:
  assumes "a  U" and "b  U" and "a <ow b"
  shows "infinite {a<ow..<owb}"
    is dense_linorder_class.infinite_Ioo.

tts_lemma atLeastLessThan_subseteq_atLeastAtMost_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows 
    "((on U with (≤ow) (<ow) : {a..<b})  {c..owd}) = 
      (a <ow b  b ow d  c ow a)"
    is dense_linorder_class.atLeastLessThan_subseteq_atLeastAtMost_iff.

tts_lemma greaterThanAtMost_subseteq_atLeastAtMost_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a<ow..b}  {c..owd}) = (a <ow b  b ow d  c ow a)"
    is dense_linorder_class.greaterThanAtMost_subseteq_atLeastAtMost_iff.

tts_lemma greaterThanAtMost_subseteq_atLeastLessThan_iff:
  assumes "a  U"
    and "b  U"
    and "c  U"
    and "d  U"
  shows "({a<ow..b}  (on U with (≤ow) (<ow) : {c..<d})) = 
    (a <ow b  b <ow d  c ow a)"
    is dense_linorder_class.greaterThanAtMost_subseteq_atLeastLessThan_iff.

tts_lemma greaterThanLessThan_subseteq_atLeastAtMost_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a<ow..<owb}  {c..owd}) = (a <ow b  b ow d  c ow a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_atLeastAtMost_iff.

tts_lemma greaterThanLessThan_subseteq_atLeastLessThan_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows 
    "({a<ow..<owb}  (on U with (≤ow) (<ow) : {c..<d})) = 
      (a <ow b  b ow d  c ow a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_atLeastLessThan_iff.

tts_lemma greaterThanLessThan_subseteq_greaterThanAtMost_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a<ow..<owb}  {c<ow..d}) = (a <ow b  b ow d  c ow a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_greaterThanAtMost_iff.

tts_lemma greaterThanLessThan_subseteq_greaterThanLessThan:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({a<ow..<owb}  {c<ow..<owd}) = (a <ow b  b ow d  c ow a)"
    is dense_linorder_class.greaterThanLessThan_subseteq_greaterThanLessThan.

end

end

text‹\newpage›

end

Theory SML_Topological_Space

(* Title: Examples/SML_Relativization/Topology/SML_Topological_Space.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about simple topological spaces›
theory SML_Topological_Space
  imports 
    "../Simple_Orders/SML_Simple_Orders"
    "HOL-Analysis.Elementary_Topology"
    "../Foundations/Transfer_Ext"
    "../Foundations/Lifting_Set_Ext"
begin



subsection‹Definitions and common properties›


text‹
Some of the entities that are presented in this subsection were 
copied from the theory text‹HOL-Types_To_Sets/Examples/T2_Spaces›.
›

locale topological_space_ow = 
  fixes U :: "'at set" and τ :: "'at set  bool"
  assumes open_UNIV[simp, intro]: "τ U"
  assumes open_Int[intro]: 
    " S  U; T  U; τ S; τ T   τ (S  T)"
  assumes open_Union[intro]: 
    " K  Pow U; SK. τ S   τ (K)"
begin

context
  includes lifting_syntax
begin

tts_register_sbts τ | U
proof-
  assume dom_ATA: "Domainp ATA = (λx. x  U)" 
    and "bi_unique ATA" 
    and "right_total ATA"
  from ‹bi_unique ATA ‹right_total ATA 
  obtain Rep :: "'a  'at" and Abs :: "'at  'a" where 
    td: "type_definition Rep Abs (Collect (Domainp ATA))" and
    ATA_Rep: "ATA b b' = (b = Rep b')" for b b'
    by (blast dest: ex_type_definition)
  define τ' where τ': "τ' = (image Rep ---> id) τ"
  have Domainp_scr_S: "Domainp (rel_set ATA) = (λx. x  U)"
    unfolding Domainp_set by (auto simp: dom_ATA)
  have scr_S_rep[intro, simp]: "rel_set ATA (image Rep a) a" for a 
    unfolding rel_set_def by (auto simp: ATA_Rep)
  have rel_set_eq_rep_set: "rel_set ATA x y  x = image Rep y" for x y
  proof -
    have "bi_unique (rel_set ATA)" 
      by (simp add: ‹bi_unique ATA bi_unique_rel_set)
    from this show ?thesis by (auto dest: bi_uniqueDl)
  qed  
  have "(rel_set ATA ===> (=)) τ τ'"
    unfolding τ' map_fun_apply id_def
    apply(intro rel_funI)
    unfolding rel_set_eq_rep_set
    apply(elim ssubst)
    ..  
  then show " τ'. (rel_set ATA ===> (=)) τ τ'" by auto
qed

end

end

locale topological_space_pair_ow = 
  ts1: topological_space_ow U1 τ1 + ts2: topological_space_ow U2 τ2 
  for U1 :: "'at set" and τ1 and U2 :: "'bt set" and τ2

locale topological_space_triple_ow = 
  ts1: topological_space_ow U1 τ1 + 
  ts2: topological_space_ow U2 τ2 +
  ts3: topological_space_ow U3 τ3
  for U1 :: "'at set" and τ1 
    and U2 :: "'bt set" and τ2 
    and U3 :: "'ct set" and τ3
begin

sublocale tsp12: topological_space_pair_ow U1 τ1 U2 τ2 ..
sublocale tsp13: topological_space_pair_ow U1 τ1 U3 τ3 ..
sublocale tsp23: topological_space_pair_ow U2 τ2 U3 τ3 ..
sublocale tsp21: topological_space_pair_ow U2 τ2 U1 τ1 ..
sublocale tsp31: topological_space_pair_ow U3 τ3 U1 τ1 ..
sublocale tsp32: topological_space_pair_ow U3 τ3 U2 τ2 ..

end

inductive generate_topology_on :: "['at set set, 'at set, 'at set]  bool" 
  (
    (in'_topology'_generated'_by _ on _ : «open» _) 
    [1000, 1000, 1000] 10
  )
  for S :: "'at set set" 
  where
    UNIV: "(in_topology_generated_by S on U : «open» U)"
  | Int: "(in_topology_generated_by S on U : «open» (a  b))" 
    if "(in_topology_generated_by S on U : «open» a)" 
      and "(in_topology_generated_by S on U : «open» b)" 
      and "a  U" 
      and "b  U"
  | UN: "(in_topology_generated_by S on U : «open» (K))"
    if "K  Pow U" 
      and "(k. k  K  (in_topology_generated_by S on U : «open» k))"
  | Basis: "(in_topology_generated_by S on U : «open» s)" 
      if "s  S" and "s  U"

lemma gto_imp_ss: "(in_topology_generated_by S on U : «open» A)  A  U"
  by (induction rule: generate_topology_on.induct) auto

lemma gt_eq_gto: "generate_topology = (λS. generate_topology_on S UNIV)"
proof(intro ext iffI)
  fix S and x :: "'a set"
  assume "generate_topology S x"
  then show "in_topology_generated_by S on UNIV : «open» x"
    by (induction rule: generate_topology.induct)
      (simp_all add: UNIV Int UN Basis)
next
  fix S and x :: "'a set"
  assume gto: "in_topology_generated_by S on UNIV : «open» x"
  define U where U: "U = (UNIV::'a set)"
  from gto have "generate_topology_on S U x" unfolding U .
  from this U show "generate_topology S x"
    by (induction rule: generate_topology_on.induct)
      (
        simp_all add: 
          generate_topology.UNIV 
          generate_topology.Int
          generate_topology.UN
          generate_topology.Basis
      )
qed 

ud ‹topological_space.closed› ((with _ : «closed» _) [1000, 1000] 10)
ud closed' ‹closed›
ud ‹topological_space.compact› ((with _ : «compact» _) [1000, 1000] 10)
ud compact' ‹compact›
ud ‹topological_space.connected› ((with _ : «connected» _) [1000, 1000] 10)
ud connected' ‹connected›
ud ‹topological_space.islimpt› ((with _ : _ «islimpt» _) [1000, 1000, 1000] 60)
ud islimpt' ‹topological_space_class.islimpt›
ud ‹interior› ((with _ : «interior» _) [1000, 1000] 10)
ud ‹closure› ((with _ : «closure» _) [1000, 1000] 10)
ud ‹frontier› ((with _ : «frontier» _) [1000, 1000] 10)
ud ‹countably_compact› ((with _ : «countably'_compact» _) [1000, 1000] 10)

definition topological_basis_with :: "['a set  bool, 'a set set]  bool"
  ((with _ : «topological'_basis» _) [1000, 1000] 10)
  where
  "(with τ : «topological_basis» B) = 
    (B = UNIV  (b  B. τ b)  (q. τ q  (B'B. B' = q)))"

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "bi_unique A" "right_total A" 
  trp (?'a A)
  in closed_ow: closed.with_def 
    ((on _ with _ : «closed» _) [1000, 1000] 10)
    and compact_ow: compact.with_def
      ((on _ with _ : «compact» _) [1000, 1000, 1000] 10)
    and connected_ow: connected.with_def 
      ((on _ with _ : «connected» _) [1000, 1000, 1000] 10)
    and islimpt_ow: islimpt.with_def 
      ((on _ with _ : _ «islimpt» _) [1000, 1000, 1000, 1000] 10)
    and interior_ow: interior.with_def
      ((on _ with _ : «interior» _) [1000, 1000, 1000] 10)
    and closure_ow: closure.with_def 
      ((on _ with _ : «closure» _) [1000, 1000, 1000] 10)
    and frontier_ow: frontier.with_def 
      ((on _ with _ : «frontier» _) [1000, 1000, 1000] 10)
    and countably_compact_ow: countably_compact.with_def
      ((on _ with _ : «countably'_compact» _) [1000, 1000, 1000] 10)

context topological_space_ow
begin

abbreviation closed where "closed  closed_ow U τ"
abbreviation compact where "compact  compact_ow U τ"
abbreviation connected where "connected  connected_ow U τ"
abbreviation islimpt (infixr «islimpt» 60) 
  where "x «islimpt» S  on U with τ : x «islimpt» S"
abbreviation interior where "interior  interior_ow U τ"
abbreviation closure where "closure  closure_ow U τ"
abbreviation frontier where "frontier  frontier_ow U τ"
abbreviation countably_compact 
  where "countably_compact  countably_compact_ow U τ"

end

context
  includes lifting_syntax
begin

private lemma Domainp_fun_rel_eq_subset:
  fixes A :: "['a, 'c]  bool"
  fixes B :: "['b, 'd]  bool"
  assumes "bi_unique A" "bi_unique B"
  shows 
    "Domainp (A ===> B) = 
      (λf. f ` (Collect (Domainp A))  (Collect (Domainp B)))"
proof(intro ext, standard)
  let ?sA = "Collect (Domainp A)" and ?sB = "(Collect (Domainp B))"  
  fix f assume "Domainp (A ===> B) f" show "f ` ?sA  ?sB"
  proof(clarsimp)
    fix x x' assume "A x x'"
    from ‹Domainp (A ===> B) f obtain f' where f': 
      "A x x'  B (f x) (f' x')" for x x'
      unfolding rel_fun_def by auto
    with A x x' have "B (f x) (f' x')" by simp
    thus "Domainp B (f x)" by auto
  qed
next
  let ?sA = "Collect (Domainp A)" and ?sB = "(Collect (Domainp B))"  
  fix f assume "f ` ?sA  ?sB"
  define f' where f': "f' = (λx'. (THE y'. x. A x x'  B (f x) y'))"
  have "(A ===> B) f f'"
  proof(intro rel_funI)
    fix x x' assume "A x x'"
    then have "f x  ?sB" using f ` ?sA  ?sB by auto
    then obtain y' where y': "B (f x) y'" by clarsimp
    have "f' x' = y'" unfolding f'
    proof 
      from A x x' y' show "x. A x x'  B (f x) y'" by auto
      {
        fix y'' assume "x. A x x'  B (f x) y''"
        then obtain x'' where x'': "A x'' x'  B (f x'') y''" by clarsimp
        with assms(1) have "x'' = x" using A x x' by (auto dest: bi_uniqueDl)
        with y' x'' have "y'' = y'" using assms(2) by (auto dest: bi_uniqueDr)
      }
      thus "x. A x x'  B (f x) y''  y'' = y'" for y'' by simp
    qed
    thus "B (f x) (f' x')" using y' by simp 
  qed
  thus "Domainp (A ===> B) f" by auto
qed

private lemma Ex_rt_bu_transfer[transfer_rule]:
  fixes A :: "['a, 'c]  bool"
  fixes B :: "['b, 'd]  bool"
  assumes [transfer_rule]: "bi_unique A" "right_total A" "bi_unique B"
  shows 
    "(((B ===> A) ===> (=)) ===> (=)) 
      (Bex (Collect (λf. f ` (Collect (Domainp B))  (Collect (Domainp A))))) 
      Ex"
proof-
  from assms(3,1) have domainp_eq_ss:
    "Domainp (B ===> A) = 
      (λf. f ` (Collect (Domainp B))  (Collect (Domainp A)))"
    by (rule Domainp_fun_rel_eq_subset)
  have "right_total (B ===> A)" 
    using assms by (simp add: bi_unique_alt_def right_total_fun)
  then have     
    "(((B ===> A) ===> (=)) ===> (=)) (Bex (Collect (Domainp (B ===> A)))) Ex"
    by (simp add: right_total_Ex_transfer)
  thus ?thesis unfolding domainp_eq_ss by simp
qed

end

definition topological_basis_ow :: 
  "['a set, 'a set  bool, 'a set set]  bool"
  ((on _ with _ : «topological'_basis» _) [1000, 1000, 1000] 10) 
  where
    "(on U with τ : «topological_basis» B) =
      (B = U  (b  B. τ b)  (q  U. τ q  (B' B. B' = q)))"

context topological_space
begin

lemma topological_basis_with[ud_with]: 
  "topological_basis = topological_basis_with open"
  unfolding topological_basis_def topological_basis_with_def Ball_def
  by (intro ext) (metis Union_mono open_UNIV top.extremum_uniqueI)

end



subsection‹Transfer rules›


text‹Some of the entities that are presented in this subsectionwere 
copied from text‹HOL-Types_To_Sets/Examples/T2_Spaces›.›

context 
  includes lifting_syntax 
begin

lemmas vimage_transfer[transfer_rule] = vimage_transfer

lemma topological_space_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "((rel_set A ===> (=)) ===> (=)) 
      (topological_space_ow (Collect (Domainp A))) class.topological_space"
  unfolding topological_space_ow_def class.topological_space_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Pow_def Ball_Collect[symmetric]
  by auto

lemma generate_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "((rel_set (rel_set A)) ===> (rel_set A ===> (=))) 
      (λB. generate_topology_on B (Collect (Domainp A))) generate_topology"
proof(intro rel_funI, standard)
  fix BL BR xl xr
  assume 
    rsrsT_BLR: "rel_set (rel_set A) BL BR" and 
    rsT_xl_xr: "rel_set A xl xr" and 
    gto: "generate_topology_on BL (Collect (Domainp A)) xl" 
  define CDT where CDT: "CDT = (Collect (Domainp A))"
  with gto have gto_CDT: "generate_topology_on BL CDT xl" by simp
  from gto_CDT CDT rsrsT_BLR rsT_xl_xr show "generate_topology BR xr"
  proof(induction arbitrary: xr rule: generate_topology_on.induct)
    case (UNIV S) show ?case
    proof -
      from assms UNIV.prems have "xr = UNIV" 
        by (meson bi_uniqueDr bi_unique_rel_set right_total_UNIV_transfer)
      thus "generate_topology BR xr" by (simp add: generate_topology.UNIV)
    qed
  next
    case (Int S a b) show ?case 
    proof -
      from Int.hyps(3) Int.prems(1) obtain a' where a': "rel_set A a a'"
        by (metis Ball_Collect Domainp_iff Domainp_set)
      from Int.hyps(4) Int.prems(1) obtain b' where b': "rel_set A b b'" 
        by (metis Ball_Collect Domainp_iff Domainp_set)
      from Int.prems(1) Int.prems(2) a' have gt_a': "generate_topology BR a'" 
         by (rule Int.IH(1))
      from Int.prems(1) Int.prems(2) b' have gt_b': "generate_topology BR b'" 
        by (rule Int.IH(2))
      from gt_a' gt_b' have "generate_topology BR (a'  b')" 
        by (rule generate_topology.Int)
      also from assms(1) a' b' Int.prems(3) have "a'  b' = xr" 
        by (rule bi_unique_intersect_r)
      ultimately show "generate_topology BR xr" by simp      
    qed
  next
    case (UN K S) thus ?case
    proof -
      define K' where K': "K' = {(x, y). rel_set A x y} `` K" (is "K' = ?K'")
      have Union_ss_CDT: "K  Collect (Domainp A)"
        by (metis CollectI Domainp.DomainI UN.prems(3) rel_setD1 subsetI)
      from assms(1) Union_ss_CDT UN.prems(3) have "?K' = xr"
        by (rule bi_unique_Union_r)
      then have UK_eq_xr: "K' = xr" unfolding K' .
      have "k'  K'  generate_topology BR k'" for k'
      proof -
        assume k'_in_K': "k'  K'"
        then obtain k where k: "rel_set A k k'" unfolding K' by auto
        from assms(1) have "bi_unique (rel_set A)" by (rule bi_unique_rel_set)
        with k have "∃!k. rel_set A k k'" by (meson bi_uniqueDl)
        with k'_in_K' k have k_in_K: "k  K" unfolding K' by auto
        from k_in_K UN.prems(1,2) k show "generate_topology BR k'" 
          by (rule UN.IH)
      qed
      then have "generate_topology BR (K')" by (rule generate_topology.UN)
      with UK_eq_xr show "generate_topology BR xr" by simp     
    qed
  next
    case (Basis xl S) thus ?case 
      using assms(1)
      by (metis Int_absorb1 bi_unique_intersect_r generate_topology.Basis 
          rel_setD1 subset_refl)
  qed
next
  fix BL BR xl xr
  assume rsrsT_BLR: "rel_set (rel_set A) BL BR" 
    and rsT_xl_xr: "rel_set A xl xr" 
    and gt: "generate_topology BR xr"  
  from gt rsrsT_BLR rsT_xl_xr show 
    "generate_topology_on BL (Collect (Domainp A)) xl"
  proof(induction arbitrary: xl rule: generate_topology.induct)
    case UNIV thus ?case using assms 
      by (metis bi_uniqueDl bi_unique_rel_set generate_topology_on.simps 
          right_total_UNIV_transfer)
  next
    case (Int a' b') show ?case
    proof -
      from assms(2) obtain a where a: "rel_set A a a'"
        by (meson right_totalE right_total_rel_set)
      from assms(2) obtain b where b: "rel_set A b b'" 
        by (meson right_totalE right_total_rel_set)
      from Int.prems(1) a have gto_a: 
        "generate_topology_on BL {x. Domainp A x} a"
        by (rule Int.IH(1))
      from Int.prems(1) b have gto_b: 
        "generate_topology_on BL {x. Domainp A x} b"
        by (rule Int.IH(2))
      from a have a_ss_DT: "a  {x. Domainp A x}"
        by auto (meson Domainp.DomainI rel_setD1)
      from b have b_ss_DT: "b  {x. Domainp A x}"
        by auto (meson Domainp.DomainI rel_setD1)
      from gto_a gto_b a_ss_DT b_ss_DT have 
        "generate_topology_on BL {x. Domainp A x} (a  b)" 
        by (rule generate_topology_on.Int)
      also from assms(1) a b Int.prems(2) have "a  b = xl" 
        by (rule bi_unique_intersect_l)
      ultimately show "generate_topology_on BL {a. Domainp A a} xl" by simp      
    qed
  next
    case (UN K') thus ?case
    proof -
      define K where K: "K = {(x, y). rel_set (λy x. A x y) x y} `` K'" 
        (is "K = ?K")
      from assms(2) have Union_ss_CRT: "K'  Collect (Rangep A)"
        by (auto simp add: Domainp_iff right_total_def)
      from assms(1) Union_ss_CRT UN.prems(2) have "?K = xl"
        by (rule bi_unique_Union_l)
      then have UK_eq_xr: "K = xl" unfolding K .
      then have "K  Pow xl" by blast
      moreover from UN.prems(2) have "xl  {x. Domainp A x}" 
        unfolding rel_set_def by blast
      ultimately have UN_prem_1: "K  Pow {x. Domainp A x}" by auto
      have UN_prem_2:
        "k  K  generate_topology_on BL {x. Domainp A x} k" for k
      proof -
        assume k_in_K: "k  K"
        with UN_prem_1 have k_ss_DT: "k  {x. Domainp A x}" by auto
        with k_in_K obtain k' where k': "rel_set (λy x. A x y) k' k"
          unfolding K Ball_Collect[symmetric] by blast
        from assms(1) have "bi_unique (λy x. A x y)" 
          unfolding bi_unique_def by simp
        then have "bi_unique (rel_set (λy x. A x y))" 
          by (rule bi_unique_rel_set)
        with k' have "∃!k'. rel_set (λy x. A x y) k' k" by (meson bi_uniqueDl)
        with k_in_K k' have k'_in_K': "k'  K'" unfolding K by blast
        from k' have rsT_kk': "rel_set A k k'" unfolding rel_set_def by auto
        from k'_in_K' UN.prems(1) rsT_kk' show 
          "generate_topology_on BL {x. Domainp A x} k"
          by (rule UN.IH)
      qed
      from UN_prem_1 UN_prem_2 have 
        "generate_topology_on BL {x. Domainp A x} (K)" 
        by (rule generate_topology_on.UN)
      with UK_eq_xr show "generate_topology_on BL {a. Domainp A a} xl" by simp           
    qed
  next
    case (Basis xr) thus ?case
    proof -
      assume xr_in_BR: "xr  BR" 
        and rsrsT_BL_BR: "rel_set (rel_set A) BL BR" 
        and rsT_xl_xr: "rel_set A xl xr"
      with assms(1) have "xl  BL"
        by (metis bi_uniqueDl bi_unique_rel_set rel_setD2)
      also with rsrsT_BL_BR  have "xl  {a. Domainp A a}" 
        unfolding Ball_Collect[symmetric] by (meson Domainp.DomainI rel_setD1)
      ultimately show "generate_topology_on BL {a. Domainp A a} xl"
        by (rule generate_topology_on.Basis)
    qed
  qed
qed

lemma topological_basis_with_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((rel_set A ===> (=)) ===> (rel_set (rel_set A)) ===> (=)) 
      (topological_basis_ow (Collect (Domainp A))) topological_basis_with"
  unfolding topological_basis_ow_def topological_basis_with_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_Collect[symmetric]
  apply(clarsimp, intro ext iffI)
  subgoal by (metis UnionI)
  subgoal by metis
  done

end



subsection‹Relativization›

tts_context
  tts: (?'a to U1::'a set›) and (?'b to U2::'b set›)
  rewriting ctr_simps
begin

tts_lemma generate_topology_Union:
  assumes "U1  {}"
    and "U2  {}"
    and "I  U1"
    and "S  Pow U2"
    and "xU1. K (x::'a)  U2"
    and 
      "k. k  U1; k  I  
        in_topology_generated_by S on U2 : «open» (K k)"
  shows "in_topology_generated_by S on U2 : «open» ( (K ` I))"
    is generate_topology_Union.

end

tts_context
  tts: (?'a to U::'a set›)
  rewriting ctr_simps
  eliminating through
    (unfold topological_space_ow_def; auto intro: generate_topology_on.intros)
begin

tts_lemma topological_space_generate_topology:
  shows "topological_space_ow U (generate_topology_on S U)"
    is topological_space_generate_topology.

end

context topological_space_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating through (metis open_UNIV)
begin

tts_lemma open_empty[simp]:
  shows "τ {}"
    is topological_space_class.open_empty.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating through 
    (
      unfold 
        closed_ow_def 
        compact_ow_def
        connected_ow_def 
        interior_ow_def 
        closure_ow_def
        frontier_ow_def, 
      auto
    )
begin

tts_lemma closed_empty[simp]: "closed {}"
  is topological_space_class.closed_empty.
    
tts_lemma closed_UNIV[simp]: "closed U"
  is topological_space_class.closed_UNIV.
    
tts_lemma compact_empty[simp]: "compact {}"
  is topological_space_class.compact_empty.
    
tts_lemma connected_empty[simp]: "connected {}"
  is topological_space_class.connected_empty.
    
tts_lemma interior_empty[simp]: "interior {} = {}"
  is interior_empty.
    
tts_lemma closure_empty[simp]: "closure {} = {}"
  is closure_empty.
    
tts_lemma closure_UNIV[simp]: "closure U = U"
  is closure_UNIV.
    
tts_lemma frontier_empty[simp]: "frontier {} = {}"
  is frontier_empty.
    
tts_lemma frontier_UNIV[simp]: "frontier U = {}"
  is frontier_UNIV.
    
end  

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating through (auto simp: UNIV inj_on_def)
begin

tts_lemma connected_Union:
  assumes "S  Pow U" and "s. s  S  connected s" and " S  U  {}"
  shows "connected ( S)"
    given Topological_Spaces.connected_Union
    by simp

tts_lemma connected_Un:
  assumes "s  U"
    and "t  U"
    and "connected s"
    and "connected t"
    and "s  t  {}"
  shows "connected (s  t)"
    is Topological_Spaces.connected_Un.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} and ?A  ?B
  through (auto simp: UNIV inj_on_def)
begin

tts_lemma connected_sing:
  assumes "x  U"
  shows "connected {x}"
  is topological_space_class.connected_sing.
    
tts_lemma topological_basisE:
  assumes "B  Pow U"
    and "O'  U"
    and "x  U"
    and "on U with τ : «topological_basis» B"
    and "τ O'"
    and "x  O'"
    and "B'. B'  U; B'  B; x  B'; B'  O'  thesis"
  shows thesis
is topological_space_class.topological_basisE.
    
tts_lemma islimptE:
  assumes "x  U"
    and "S  U"
    and "T  U"
    and "x «islimpt» S"
    and "x  T"
    and "τ T"
    and "y. y  U; y  S; y  T; y  x  thesis"
  shows thesis
    is Elementary_Topology.islimptE.
    
tts_lemma islimpt_subset:
  assumes "x  U" and "T  U" and "x «islimpt» S" and "S  T"
  shows "x «islimpt» T"
    is Elementary_Topology.islimpt_subset.
    
tts_lemma islimpt_UNIV_iff:
  assumes "x  U"
  shows "x «islimpt» U = (¬ τ {x})"
    is Elementary_Topology.islimpt_UNIV_iff.
    
tts_lemma islimpt_punctured:
  assumes "x  U" and "S  U"
  shows "x «islimpt» S = x «islimpt» S - {x}"
    is Elementary_Topology.islimpt_punctured.
    
tts_lemma islimpt_EMPTY:
  assumes "x  U"
  shows "¬ x «islimpt» {}"
    is Elementary_Topology.islimpt_EMPTY.
    
tts_lemma islimpt_Un:
  assumes "x  U" and "S  U" and "T  U"
  shows "x «islimpt» S  T = (x «islimpt» S  x «islimpt» T)"
    is Elementary_Topology.islimpt_Un.
    
tts_lemma interiorI:
  assumes "x  U" and "S  U" and "τ T" and "x  T" and "T  S"
  shows "x  interior S"
    is Elementary_Topology.interiorI.

tts_lemma islimpt_in_closure:
  assumes "x  U" and "S  U"
  shows "x «islimpt» S = (x  closure (S - {x}))"
    is Elementary_Topology.islimpt_in_closure.

tts_lemma compact_sing:
  assumes "a  U"
  shows "compact {a}"
    is Elementary_Topology.compact_sing.
    
tts_lemma compact_insert:
  assumes "s  U" and "x  U" and "compact s"
  shows "compact (insert x s)"
    is Elementary_Topology.compact_insert.
    
tts_lemma open_Un:
  assumes "S  U" and "T  U" and "τ S" and "τ T"
  shows "τ (S  T)"
    is topological_space_class.open_Un.
    
tts_lemma open_Inter:
  assumes "S  Pow U" and "finite S" and "Ball S τ"
  shows "τ ( S  U)"
    is topological_space_class.open_Inter.
    
tts_lemma openI:
  assumes "S  U" and "x. x  U; x  S  yU. τ y  y  S  x  y"
  shows "τ S"
    given topological_space_class.openI by (meson PowI)
    
tts_lemma closed_Un:
  assumes "S  U" and "T  U" and "closed S" and "closed T"
  shows "closed (S  T)"
    is topological_space_class.closed_Un.

tts_lemma closed_Int:
  assumes "S  U" and "T  U" and "closed S" and "closed T"
  shows "closed (S  T)"
  is topological_space_class.closed_Int.

tts_lemma open_Collect_conj:
  assumes "τ {x. P x  x  U}" and "τ {x. Q x  x  U}"
  shows "τ {x  U. P x  Q x}"
    is topological_space_class.open_Collect_conj.

tts_lemma open_Collect_disj:
  assumes "τ {x. P x  x  U}"
    and "τ {x. Q x  x  U}"
  shows "τ {x  U. P x  Q x}"
    is topological_space_class.open_Collect_disj.

tts_lemma open_Collect_imp:
  assumes "closed {x. P x  x  U}"
    and "τ {x. Q x  x  U}"
  shows "τ {x  U. P x  Q x}"
    is topological_space_class.open_Collect_imp.

tts_lemma open_Collect_const: "τ {x. P  x  U}"
    is topological_space_class.open_Collect_const.
    
tts_lemma closed_Collect_conj:
  assumes "closed {x. P x  x  U}" and "closed {x. Q x  x  U}"
  shows "closed {x  U. P x  Q x}"
    is topological_space_class.closed_Collect_conj.

tts_lemma closed_Collect_disj:
  assumes "closed {x. P x  x  U}" and "closed {x. Q x  x  U}"
  shows "closed {x  U. P x  Q x}"
    is topological_space_class.closed_Collect_disj.

tts_lemma closed_Collect_imp:
  assumes "τ {x. P x  x  U}" and "closed {x. Q x  x  U}"
  shows "closed {x  U. P x  Q x}"
    is topological_space_class.closed_Collect_imp.
    
tts_lemma compact_Int_closed:
  assumes "S  U" and "T  U" and "compact S" and "closed T"
  shows "compact (S  T)"
  is topological_space_class.compact_Int_closed.
    
tts_lemma compact_diff:
  assumes "S  U" and "T  U" and "compact S" and "τ T"
  shows "compact (S - T)"
  is topological_space_class.compact_diff.
    
tts_lemma connectedD:
  assumes "U  U"
    and "V  U"
    and "connected A"
    and "τ U"
    and "τ V"
    and "U  (V  A) = {}"
    and "A  U  V"
  shows "U  A = {}  V  A = {}"
  is topological_space_class.connectedD.

tts_lemma topological_basis_open:
  assumes "B  Pow U" and "on U with τ : «topological_basis» B" and "X  B"
  shows "τ X"
    is topological_space_class.topological_basis_open.

tts_lemma topological_basis_imp_subbasis:
  assumes "B  Pow U" and "on U with τ : «topological_basis» B"
  shows "sU. τ s = (in_topology_generated_by B on U : «open» s)"
  is topological_space_class.topological_basis_imp_subbasis.

tts_lemma connected_closedD:
  assumes "A  U"
    and "B  U"
    and "connected s"
    and "A  (B  s) = {}"
    and "s  A  B"
    and "closed A"
    and "closed B"
  shows "A  s = {}  B  s = {}"
    is Topological_Spaces.connected_closedD.
    
tts_lemma connected_diff_open_from_closed:
  assumes "u  U"
    and "s  t"
    and "t  u"
    and "τ s"
    and "closed t"
    and "connected u"
    and "connected (t - s)"
  shows "connected (u - s)"
    is Topological_Spaces.connected_diff_open_from_closed.

tts_lemma interior_maximal:
  assumes "S  U" and "T  S" and "τ T"
  shows "T  interior S"
    is Elementary_Topology.interior_maximal.

tts_lemma open_subset_interior:
  assumes "S  U" and "T  U" and "τ S"
  shows "(S  interior T) = (S  T)"
    is Elementary_Topology.open_subset_interior.

tts_lemma interior_mono:
  assumes "T  U" and "S  T"
  shows "interior S  interior T"
    is Elementary_Topology.interior_mono.

tts_lemma interior_Int:
  assumes "S  U" and "T  U"
  shows "interior (S  T) = interior S  interior T"
    is Elementary_Topology.interior_Int.

tts_lemma interior_closed_Un_empty_interior:
  assumes "S  U" and "T  U" and "closed S" and "interior T = {}"
  shows "interior (S  T) = interior S"
    is Elementary_Topology.interior_closed_Un_empty_interior.

tts_lemma countably_compact_imp_acc_point:
  assumes "local.countably_compact s"
    and "countable t"
    and "infinite t"
    and "t  s"
  shows "xs. UPow U. τ U  x  U  infinite (U  t)"
    is Elementary_Topology.countably_compact_imp_acc_point.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} 
    through (auto simp: UNIV inj_on_def)
begin

tts_lemma first_countableI:
  assumes "𝒜  Pow U"
    and "x  U"
    and "countable 𝒜"
    and "A. A  𝒜  x  A"
    and "A. A  𝒜  τ A"
    and "S. τ S; x  S  A𝒜. A  S"
  shows "𝒜{f. range f  Pow U}. 
    (i. τ (𝒜 (i::nat))  x  𝒜 i)  
    (SPow U. τ S  x  S  (i. 𝒜 i  S))"
    given topological_space_class.first_countableI by auto

tts_lemma islimptI:
  assumes "x  U"
    and "S  U"
    and "T. x  T; τ T  yS. y  T  y  x"
  shows "x «islimpt» S"
    given Elementary_Topology.islimptI
  by simp
    
tts_lemma interiorE:
  assumes "x  U"
    and "S  U"
    and "x  interior S"
    and "T. T  U; τ T; x  T; T  S  thesis"
  shows thesis
    is Elementary_Topology.interiorE.
    
tts_lemma closure_iff_nhds_not_empty:
  assumes "x  U" and "X  U"
  shows 
    "(x  closure X) = 
      (yU. zU. z  y  τ z  x  z  X  y  {})"
    given Elementary_Topology.closure_iff_nhds_not_empty by auto

tts_lemma basis_dense:
  assumes "B  Pow U"
    and "xU. f x  U"
    and "on U with τ : «topological_basis» B"
    and "B'. B'  U; B'  {}  f B'  B'"
  shows "xU. τ x  x  {}  (yB. f y  x)"
    given topological_space_class.basis_dense by auto
    
tts_lemma inj_setminus:
  assumes "A  Pow U"
  shows "inj_on (λS. - S  U) A"
    is topological_space_class.inj_setminus.
    
end


tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} and ?S  U through
    (
      unfold 
        closed_ow_def 
        compact_ow_def   
        connected_ow_def 
        interior_ow_def
        topological_basis_ow_def
        closure_ow_def 
        frontier_ow_def
        countably_compact_ow_def,
      auto 
    )      
begin

tts_lemma closed_Inter:
  assumes "K  Pow U" and "Ball K closed"
  shows "closed ( K  U)"
  is topological_space_class.closed_Inter.
    
tts_lemma closed_Union:
  assumes "S  Pow U" and "finite S" and "Ball S closed"
  shows "closed ( S)"
  is topological_space_class.closed_Union.
    
tts_lemma open_closed:
  assumes "S  U"
  shows "τ S = closed (- S  U)"
    is topological_space_class.open_closed.
    
tts_lemma closed_open:
  shows "closed S = τ (- S  U)"
    is topological_space_class.closed_open.
    
tts_lemma open_Diff:
  assumes "S  U" and "T  U" and "τ S" and "closed T"
  shows "τ (S - T)"
    is topological_space_class.open_Diff.
    
tts_lemma closed_Diff:
  assumes "S  U" and "T  U" and "closed S" and "τ T"
  shows "closed (S - T)"
    is topological_space_class.closed_Diff.
    
tts_lemma open_Compl:
  assumes "closed S"
  shows "τ (- S  U)"
    is topological_space_class.open_Compl.
    
tts_lemma closed_Compl:
  assumes "S  U" and "τ S"
  shows "closed (- S  U)"
    is topological_space_class.closed_Compl.

tts_lemma open_Collect_neg:
  assumes "closed {x  U. P x}"
  shows "τ {x  U. ¬ P x}"
    given topological_space_class.open_Collect_neg
  by (simp add: ctr_simps_conj_commute)

tts_lemma closed_Collect_neg:
  assumes "τ {xU. P x}"
  shows "closed {xU. ¬ P x}"
    given topological_space_class.closed_Collect_neg
  by (simp add: ctr_simps_conj_commute)

tts_lemma closed_Collect_const: "closed {x  U. P}"
  given topological_space_class.closed_Collect_const 
  by (simp add: ctr_simps_conj_commute)
    
tts_lemma connectedI:
  assumes 
    "A B. 
      
        A  U; 
        B  U; 
        τ A; 
        τ B; 
        A  U  {}; 
        B  U  {}; 
        A  (B  U) = {}; 
        U  A  B
        False"
  shows "connected U"
    is topological_space_class.connectedI.

tts_lemma topological_basis:
  assumes "B  Pow U" 
  shows "(on U with τ : «topological_basis» B) = 
    (xPow U. τ x = (B'Pow (Pow U). B'  B   B' = x))"
    is topological_space_class.topological_basis.

tts_lemma topological_basis_iff:
  assumes "B  Pow U" and "B'. B'  U; B'  B  τ B'"
  shows "(on U with τ : «topological_basis» B) = 
    (O'Pow U. τ O'  (xO'. B'B. B'  O'  x  B'))"
    is topological_space_class.topological_basis_iff.

tts_lemma topological_basisI:
  assumes "B  Pow U"
    and "B'. B'  U; B'  B  τ B'"
    and "O' x. O'  U; x  U; τ O'; x  O'  yB. y  O'  x  y"
  shows "on U with τ : «topological_basis» B"
    is topological_space_class.topological_basisI.
    
tts_lemma closed_closure:
  assumes "S  U"
  shows "closed (closure S)"
    is Elementary_Topology.closed_closure.
    
tts_lemma closure_subset: "S  closure S"
  is Elementary_Topology.closure_subset.
    
tts_lemma closure_eq:
  assumes "S  U"
  shows "(closure S = S) = closed S"
  is Elementary_Topology.closure_eq.
    
tts_lemma closure_closed:
  assumes "S  U" and "closed S"
  shows "closure S = S"
    is Elementary_Topology.closure_closed.
    
tts_lemma closure_closure:
  assumes "S  U"
  shows "closure (closure S) = closure S"
  is Elementary_Topology.closure_closure.
    
tts_lemma closure_mono:
  assumes "T  U" and "S  T"
  shows "closure S  closure T"
  is Elementary_Topology.closure_mono.
    
tts_lemma closure_minimal:
  assumes "T  U" and "S  T" and "closed T"
  shows "closure S  T"
  is Elementary_Topology.closure_minimal.
    
tts_lemma closure_unique:
  assumes "T  U"
    and "S  T"
    and "closed T"
    and "T'. T'  U; S  T'; closed T'  T  T'"
  shows "closure S = T"
  is Elementary_Topology.closure_unique.
    
tts_lemma closure_Un:
  assumes "S  U" and "T  U"
  shows "closure (S  T) = closure S  closure T"
    is Elementary_Topology.closure_Un.
    
tts_lemma closure_eq_empty: "(closure S = {}) = (S = {})"
  is Elementary_Topology.closure_eq_empty.
    
tts_lemma closure_subset_eq:
  assumes "S  U"
  shows "(closure S  S) = closed S"
  is Elementary_Topology.closure_subset_eq.
    
tts_lemma open_Int_closure_eq_empty:
  assumes "S  U" and "T  U" and "τ S"
  shows "(S  closure T = {}) = (S  T = {})"
    is Elementary_Topology.open_Int_closure_eq_empty.
    
tts_lemma open_Int_closure_subset:
  assumes "S  U" and "T  U" and "τ S"
  shows "S  closure T  closure (S  T)"
    is Elementary_Topology.open_Int_closure_subset.

tts_lemma closure_Un_frontier: "closure S = S  frontier S"
  is Elementary_Topology.closure_Un_frontier.

tts_lemma compact_imp_countably_compact:
  assumes "compact U"
  shows "countably_compact U"
    is Elementary_Topology.compact_imp_countably_compact.

end


tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating through auto
begin

tts_lemma Heine_Borel_imp_Bolzano_Weierstrass:
  assumes "s  U"
    and "local.compact s"
    and "infinite t"
    and "t  s"
  shows "xs. x «islimpt» t"
    is Elementary_Topology.Heine_Borel_imp_Bolzano_Weierstrass.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through
    (
      unfold 
        closed_ow_def 
        compact_ow_def   
        connected_ow_def 
        interior_ow_def
        topological_basis_ow_def
        closure_ow_def  
        frontier_ow_def
        countably_compact_ow_def, 
      auto simp: connected_iff_const
    )
begin

tts_lemma connected_closed:
  assumes "s  U"
  shows "connected s = 
    (
      ¬(APow U. BPow U. 
        closed A  
        closed B  
        s  A  B  
        A  (B  s) = {}  
        A  s  {}  
        B  s  {})
    )"
    is Topological_Spaces.connected_closed.

tts_lemma closure_complement:
  assumes "S  U"
  shows "closure (- S  U) = - interior S  U"
    is Elementary_Topology.closure_complement.
    
tts_lemma interior_complement:
  assumes "S  U"
  shows "interior (- S  U) = - closure S  U"
  is Elementary_Topology.interior_complement.
    
tts_lemma interior_diff:
  assumes "S  U" and "T  U"
  shows "interior (S - T) = interior S - closure T"
  is Elementary_Topology.interior_diff.
    
tts_lemma connected_imp_connected_closure:
  assumes "S  U" and "connected S"
  shows "connected (closure S)"
    is Elementary_Topology.connected_imp_connected_closure.
    
tts_lemma frontier_closed:
  assumes "S  U"
  shows "closed (frontier S)"
    is Elementary_Topology.frontier_closed.
    
tts_lemma frontier_Int:
  assumes "S  U" and "T  U"
  shows "frontier (S  T) = closure (S  T)  (frontier S  frontier T)"
    is Elementary_Topology.frontier_Int.
    
tts_lemma frontier_closures:
  assumes "S  U"
  shows "frontier S = closure S  closure (- S  U)"
    is Elementary_Topology.frontier_closures.
    
tts_lemma frontier_Int_subset:
  assumes "S  U" and "T  U"
  shows "frontier (S  T)  frontier S  frontier T"
  is Elementary_Topology.frontier_Int_subset.
    
tts_lemma frontier_Int_closed:
  assumes "S  U" and "T  U" and "closed S" and "closed T"
  shows "frontier (S  T) = frontier S  T  S  frontier T"
  is Elementary_Topology.frontier_Int_closed.
    
tts_lemma frontier_subset_closed:
  assumes "S  U" and "closed S"
  shows "frontier S  S"
  is Elementary_Topology.frontier_subset_closed.
    
tts_lemma frontier_subset_eq:
  assumes "S  U"
  shows "(frontier S  S) = closed S"
    is Elementary_Topology.frontier_subset_eq.

tts_lemma frontier_complement:
  assumes "S  U"
  shows "frontier (- S  U) = frontier S"
    is Elementary_Topology.frontier_complement.
    
tts_lemma frontier_Un_subset:
  assumes "S  U" and "T  U"
  shows "frontier (S  T)  frontier S  frontier T"
  is Elementary_Topology.frontier_Un_subset.
    
tts_lemma frontier_disjoint_eq:
  assumes "S  U"
  shows "(frontier S  S = {}) = τ S"
  is Elementary_Topology.frontier_disjoint_eq.
    
tts_lemma frontier_interiors:
  assumes "s  U"
  shows "frontier s = - interior s  U - interior (- s  U)"
is Elementary_Topology.frontier_interiors.
    
tts_lemma frontier_interior_subset:
  assumes "S  U"
  shows "frontier (interior S)  frontier S"
  is Elementary_Topology.frontier_interior_subset.

tts_lemma compact_Un:
  assumes "s  U" and "t  U" and "compact s" and "compact t"
  shows "compact (s  t)"
  is Elementary_Topology.compact_Un.
    
tts_lemma closed_Int_compact:
  assumes "s  U" and "t  U" and "closed s" and "compact t"
  shows "compact (s  t)"
    is Elementary_Topology.closed_Int_compact.
    
tts_lemma countably_compact_imp_compact:
  assumes "U  U"
    and "B  Pow U"
    and "countably_compact U"
    and "countable B"
    and "Ball B τ"
    and "T x. T  U; x  U; τ T; x  T; x  U  yB. x  y  y  U  T"
  shows "compact U"
    is Elementary_Topology.countably_compact_imp_compact.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through (insert closure_eq_empty, blast)
begin

tts_lemma closure_interior:
  assumes "S  U"
  shows "closure S = - interior (- S  U)  U"
    is Elementary_Topology.closure_interior.

end

tts_context  
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} 
    through (insert compact_empty, fastforce dest: subset_singletonD)
begin

tts_lemma compact_Union:
  assumes "S  Pow U"
    and "finite S"
    and "T. T  U; T  S  compact T"
  shows "compact ( S)"
    is Elementary_Topology.compact_Union.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through
    (
      insert 
        interior_empty 
        closure_ow_def 
        closed_UNIV 
        compact_empty
        compact_ow_def,
      auto
    )
begin

tts_lemma compactI:
  assumes "s  U"
    and "C. C  Pow U; Ball C τ; s   C  
      xPow U. x  C  finite x  s   x"
  shows "compact s"
  given topological_space_class.compactI by (meson PowI)
    
tts_lemma compactE:
  assumes "S  U"
    and "𝒯  Pow U"
    and "compact S"
    and "S   𝒯"
    and "B. B  𝒯  τ B"
    and "𝒯'. 𝒯'  Pow U; 𝒯'  𝒯; finite 𝒯'; S   𝒯'  thesis"
  shows thesis
    given topological_space_class.compactE
    by metis

tts_lemma compact_fip:
  assumes "U  U"
  shows "compact U =
    (
      xPow U.
        Ball x closed 
        (yPow U. y  x  finite y  U  ( y  U)  {}) 
        U  ( x  U)  {}
    )"
    given topological_space_class.compact_fip by auto
    
tts_lemma compact_imp_fip:
  assumes "S  U"
    and "Fa  Pow U"
    and "compact S"
    and "T. T  U; T  Fa  closed T"
    and "F'. F'  Pow U; finite F'; F'  Fa  S  ( F'  U)  {}"
  shows "S  ( Fa  U)  {}"
    is topological_space_class.compact_imp_fip.
    
tts_lemma closed_limpt:
  assumes "S  U"
  shows "closed S = (xU. x «islimpt» S  x  S)"
    is Elementary_Topology.closed_limpt.
    
tts_lemma open_interior:
  assumes "S  U"
  shows "τ (interior S)"
    is Elementary_Topology.open_interior.
    
tts_lemma interior_subset:
  assumes "S  U"
  shows "interior S  S"
    is Elementary_Topology.interior_subset.
    
tts_lemma interior_open:
  assumes "S  U" and "τ S"
  shows "interior S = S"
    is Elementary_Topology.interior_open.
    
tts_lemma interior_eq:
  assumes "S  U"
  shows "(interior S = S) = τ S"
    is Elementary_Topology.interior_eq.
    
tts_lemma interior_UNIV: "interior U = U"
  is Elementary_Topology.interior_UNIV.
    
tts_lemma interior_interior:
  assumes "S  U"
  shows "interior (interior S) = interior S"
    is Elementary_Topology.interior_interior.
    
tts_lemma interior_closure:
  assumes "S  U"
  shows "interior S = - closure (- S  U)  U"
    is Elementary_Topology.interior_closure.
    
tts_lemma finite_imp_compact:
  assumes "s  U" and "finite s"
  shows "compact s"
  is Elementary_Topology.finite_imp_compact.
    
tts_lemma countably_compactE:
  assumes "s  U"
    and "C  Pow U"
    and "countably_compact s"
    and "Ball C τ"
    and "s   C"
    and "countable C"
    and "C'. C'  Pow U; C'  C; finite C'; s   C'  thesis"
  shows thesis
    is Elementary_Topology.countably_compactE.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} and ?A  U through (insert interior_empty, auto)
begin

tts_lemma interior_unique:
  assumes "S  U"
    and "T  S"
    and "τ T"
    and "T'. T'  S; τ T'  T'  T"
  shows "interior S = T"
    given Elementary_Topology.interior_unique
  by auto

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through (simp add: subset_iff filterlim_iff)
begin

tts_lemma open_UN:
  assumes "A  U2"
    and "xU2. B x  U"
    and "xA. τ (B x)"
  shows "τ ( (B ` A))"
    is topological_space_class.open_UN.

tts_lemma open_Collect_ex:
  assumes "i. i  U2  τ {x. P i x  x  U}"
  shows "τ {x  U. iU2. P i x}"
    is open_Collect_ex.

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through (unfold closed_ow_def finite_def, auto)
begin

tts_lemma open_INT:
  assumes "A  U2" and "xU2. B x  U" and "finite A" and "xA. τ (B x)"
  shows "τ ( (B ` A)  U)"
    is topological_space_class.open_INT.
    
tts_lemma closed_INT:
  assumes "A  U2" and "xU2. B x  U" and "xA. closed (B x)"
  shows "closed ( (B ` A)  U)"
    is topological_space_class.closed_INT.
    
tts_lemma closed_UN:
  assumes "A  U2"
    and "xU2. B x  U"
    and "finite A"
    and "xA. closed (B x)"
  shows "closed ( (B ` A))"
    is topological_space_class.closed_UN.

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through (insert closed_empty, auto)
begin

tts_lemma closed_Collect_all:
  assumes "i. i  U2  local.closed {x. P i x  x  U}"
  shows "local.closed {x  U. iU2. P i x}"
    is topological_space_class.closed_Collect_all.
    
tts_lemma compactE_image:
  assumes "S  U"
    and "C  U2"
    and "xU2. f x  U"
    and "compact S"
    and "T. T  U2; T  C  τ (f T)"
    and "S   (f ` C)"
    and "C'. C'  U2; C'  C; finite C'; S   (f ` C')  thesis"
  shows thesis
    is topological_space_class.compactE_image.

end

tts_context
  tts: (?'a to U) and (?'b to U2::'b set›)
  rewriting ctr_simps
  substituting topological_space_ow_axioms
  eliminating ?U  {} through (simp, blast | simp)
begin

tts_lemma ne_compact_imp_fip_image:
  assumes "s  U"
    and "I  U2"
    and "xU2. f x  U"
    and "compact s"
    and "i. i  U2; i  I  closed (f i)"
    and "I'. I'  U2; finite I'; I'  I  s  ( (f ` I')  U)  {}"
  shows "s  ( (f ` I)  U)  {}"
    is topological_space_class.compact_imp_fip_image.

end

end



subsection‹Further results›

lemma topological_basis_closed:
  assumes "topological_basis_ow U τ B"
  shows "B  Pow U"
  using assms unfolding topological_basis_ow_def by auto

lemma ts_open_eq_ts_open:
  assumes "topological_space_ow U τ'" and "s. s  U  τ' s = τ s"
  shows "topological_space_ow U τ"
proof
  from assms(1) have "τ' U" unfolding topological_space_ow_def by simp
  with assms(2) show "τ U" by auto
  from assms(1) have "S T.  S  U; T  U; τ' S; τ' T   τ' (S  T)" 
    unfolding topological_space_ow_def by simp
  with assms(2) show "S T.  S  U; T  U; τ S; τ T   τ (S  T)"
    by (meson Int_lower1 order_trans)
  from assms(1) have "K.  K  Pow U; SK. τ' S   τ' (K)" 
    unfolding topological_space_ow_def by simp
  with assms(2) show "K.  K  Pow U; SK. τ S   τ (K)" 
    by (metis Union_Pow_eq Union_mono ctr_simps_subset_pow_iff)
qed

lemma (in topological_space_ow) topological_basis_closed:
  assumes "topological_basis_ow U τ B" 
  shows "B  Pow U"
  using assms 
  unfolding topological_basis_with_def 
  by (rule topological_basis_closed)

text‹\newpage›

end

Theory SML_Topological_Space_Countability

(* Title: Examples/SML_Relativization/Topology/SML_Topological_Space_Countability.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹
Relativization of the results related to the countability properties of 
topological spaces
›
theory SML_Topological_Space_Countability
  imports SML_Topological_Space
begin



subsection‹First countable topological space›


subsubsection‹Definitions and common properties›

locale first_countable_topology_ow = 
  topological_space_ow U τ for U :: "'at set" and τ +
  assumes first_countable_basis:
    "(
      xU. 
      (
        B::nat  'at set. 
          (i. B i  U  x  B i  τ (B i))  
          (S. S  U  τ S  x  S  (i. B i  S))
      )
    )"

locale ts_fct_ow = 
  ts: topological_space_ow U1 τ1 + fct: first_countable_topology_ow U2 τ2
  for U1 :: "'at set" and τ1 and U2 :: "'bt set" and τ2
begin

sublocale topological_space_pair_ow U1 τ1 U2 τ2 ..

end

locale first_countable_topology_pair_ow = 
  fct1: first_countable_topology_ow U1 τ1 + 
  fct2: first_countable_topology_ow U2 τ2
  for U1 :: "'at set" and τ1 and U2 :: "'bt set" and τ2
begin

sublocale ts_fct_ow U1 τ1 U2 τ2 ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

private lemma first_countable_topology_transfer_h: 
  "(i. B i  Collect (Domainp A)  x  B i  τ (B i)) =
    (B ` Collect top  {Aa. Aa  Collect (Domainp A)}  
    (i. x  B i  τ (B i)))"
  by auto

lemma first_countable_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "((rel_set A ===> (=)) ===> (=)) 
      (first_countable_topology_ow (Collect (Domainp A))) 
      class.first_countable_topology"
  unfolding 
    first_countable_topology_ow_def 
    class.first_countable_topology_def
    first_countable_topology_ow_axioms_def 
    class.first_countable_topology_axioms_def
  apply transfer_prover_start
  apply transfer_step+  
  by 
    (
      simp,
      unfold Ball_Collect, 
      intro ext, 
      unfold first_countable_topology_transfer_h
    ) 
    (metis top_set_def)

end


subsubsection‹Relativization›

context first_countable_topology_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting first_countable_topology_ow_axioms
  eliminating ?U  {} through simp
begin

tts_lemma countable_basis_at_decseq:
  assumes "x  U"
    and "A. 
      
        range A  Pow U; 
        i. τ (A i); 
        i. x  A i; 
        S. S  U; τ S; x  S  F i in sequentially. A i  S
        thesis"
  shows thesis
    is first_countable_topology_class.countable_basis_at_decseq.

tts_lemma first_countable_basisE:
  assumes "x  U"
    and "𝒜. 
      
        𝒜  Pow U; 
        countable 𝒜; 
        A. A  U; A  𝒜  x  A; 
        A. A  U; A  𝒜  τ A; 
        S. S  U; τ S; x  S  A𝒜. A  S  thesis"
  shows thesis
    is first_countable_topology_class.first_countable_basisE.

tts_lemma first_countable_basis_Int_stableE:
  assumes "x  U"
    and "𝒜. 
      
        𝒜  Pow U; 
        countable 𝒜; 
        A. A  U; A  𝒜  x  A; 
        A. A  U; A  𝒜  τ A; 
        S. S  U; τ S; x  S  A𝒜. A  S; 
        A B. A  U; B  U; A  𝒜; B  𝒜  A  B  𝒜
        thesis"
  shows thesis
    is first_countable_topology_class.first_countable_basis_Int_stableE.

end

end



subsection‹Topological space with a countable basis›


subsubsection‹Definitions and common properties›

locale countable_basis_ow = 
  topological_space_ow U τ for U :: "'at set" and τ +
  fixes B :: "'at set set"
  assumes is_basis: "topological_basis_ow U τ B"
    and countable_basis: "countable B"
begin

lemma B_ss_PowU[simp]: "B  Pow U" 
  by (simp add: is_basis topological_basis_closed)

end


subsubsection‹Transfer rules›

context 
  includes lifting_syntax
begin

lemma countable_basis_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "((rel_set A ===> (=)) ===> rel_set (rel_set A) ===> (=)) 
      (countable_basis_ow (Collect (Domainp A))) countable_basis"
proof(intro rel_funI)
  fix τ :: "'a set  bool" and τ' :: "'b set  bool" and B B'
  assume ττ'[transfer_rule]: "(rel_set A ===> (=)) τ τ'" 
    and BB'[transfer_rule]: "rel_set (rel_set A) B B'"
  show "countable_basis_ow (Collect (Domainp A)) τ B = countable_basis τ' B'"
  proof
    assume cbow: "countable_basis_ow (Collect (Domainp A)) τ B"
    interpret cbow: countable_basis_ow "Collect (Domainp A)" τ B by (rule cbow)
    interpret ts: topological_space τ' 
      by transfer (simp add: cbow.topological_space_ow_axioms)
    show "countable_basis τ' B'"
      apply unfold_locales
      subgoal
        using cbow.is_basis unfolding ts.topological_basis_with by transfer
      subgoal using cbow.countable_basis by transfer
      done
  next
    assume cb: "countable_basis τ' B'"
    interpret cb: countable_basis τ' B' by (rule cb)
    interpret tsow: topological_space_ow "Collect (Domainp A)" τ 
      using cb.topological_space_axioms by transfer
    show "countable_basis_ow (Collect (Domainp A)) τ B"
      apply unfold_locales
      subgoal using cb.is_basis unfolding cb.topological_basis_with by transfer
      subgoal using cb.countable_basis by transfer
      done
  qed
qed

end


subsubsection‹Relativization›

context countable_basis_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting countable_basis_ow_axioms
  eliminating ?U  {} through auto
  applying [OF B_ss_PowU]
begin

tts_lemma open_countable_basis_ex:
  assumes "X  U" and "τ X"
  shows "B'Pow (Pow U). B'  B  X =  B'"
    is countable_basis.open_countable_basis_ex.

tts_lemma countable_dense_exists:
  "DPow U. 
    countable D  
    (XPow U. τ X  X  {}  (dD. d  X))"
    is countable_basis.countable_dense_exists.

tts_lemma open_countable_basisE:
  assumes "X  U"
    and "τ X"
    and "B'. B'  Pow U; B'  B; X =  B'  thesis"
  shows thesis
    is countable_basis.open_countable_basisE.

tts_lemma countable_dense_setE:
  assumes "D. 
    D  U; countable D; X. X  U; τ X; X  {}  xD. x  X  thesis"
  shows thesis
    is countable_basis.countable_dense_setE.

end

end



subsection‹Second countable topological space›


subsubsection‹Definitions and common properties›

locale second_countable_topology_ow = 
  topological_space_ow U τ for U :: "'at set" and τ +
  assumes second_countable_basis:
    "BPow U. countable B  (SU. τ S = generate_topology_on B U S)"


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma second_countable_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "((rel_set A ===> (=)) ===> (=)) 
      (second_countable_topology_ow (Collect (Domainp A))) 
      class.second_countable_topology"
  unfolding 
    second_countable_topology_ow_def 
    class.second_countable_topology_def
    second_countable_topology_ow_axioms_def 
    class.second_countable_topology_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_Collect ctr_simps_subset_pow_iff''[symmetric] 
  by simp

end


subsubsection‹Relativization›

context second_countable_topology_ow 
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting second_countable_topology_ow_axioms
  eliminating ?U  {} through (unfold topological_basis_ow_def, auto)
begin

tts_lemma ex_countable_basis:
  "BPow (Pow U). countable B  (on U with τ : «topological_basis» B)"
    is Elementary_Topology.ex_countable_basis.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting second_countable_topology_ow_axioms
  eliminating ?U  {} through (auto simp: countable_subset)
begin

tts_lemma countable_dense_exists:
  "DPow U. countable D  (XPow U. τ X  X  {}  (dD. d  X))"
    is Elementary_Topology.countable_dense_exists.

tts_lemma countable_dense_setE:
  assumes "D. 
    
      D  U; 
      countable D; 
      X. X  U; τ X; X  {}  dD. d  X
      thesis"
  shows thesis
    is Elementary_Topology.countable_dense_setE.

tts_lemma univ_second_countable:
  assumes ". 
    
        Pow U; 
      countable ; 
      C. C  U; C    τ C; 
      S. S  U; τ S  UPow (Pow U). U    S =  U
      thesis"
  shows thesis
    is Elementary_Topology.univ_second_countable.

tts_lemma Lindelof:
  assumes "  Pow U"
    and "S. S  U; S    τ S"
    and "ℱ'. ℱ'  Pow U; ℱ'  ; countable ℱ';  ℱ' =    thesis"
  shows thesis
    is Elementary_Topology.Lindelof.

tts_lemma countable_disjoint_open_subsets:
  assumes "  Pow U" and "S. S  U; S    τ S" and "disjoint "
  shows "countable "
    is Elementary_Topology.countable_disjoint_open_subsets.

end

end

text‹\newpage›

end

Theory SML_Ordered_Topological_Spaces

(* Title: Examples/SML_Relativization/Topology/SML_Ordered_Topological_Spaces.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about ordered topological spaces›
theory SML_Ordered_Topological_Spaces
  imports 
    SML_Topological_Space
    "../Lattices/SML_Linorders"
begin



subsection‹Ordered topological space›


subsubsection‹Definitions and common properties›

locale order_topology_ow = 
  order_ow U le ls for U :: "'at set" and le ls +
  fixes τ :: "'at set  bool"
  assumes open_generated_order: "s  U  
    τ s = 
      (
        (
          in_topology_generated_by 
            (
              (λa. (on U with (<ow) : {..< a})) ` U  
              (λa. (on U with (<ow) : {a <..})) ` U
            ) 
          on U : «open» s 
        )
      )"
begin

sublocale topological_space_ow
proof -
  define τ' where τ': 
    "τ' = generate_topology_on 
      (
        (λa. (on U with (<ow) : {..< a})) ` U  
        (λa. (on U with (<ow) : {a <..})) ` U
      ) 
      U"
  have 
    "(
      (λa. (on U with (<ow) : {..< a})) ` U  
      (λa. (on U with (<ow) : {a <..})) ` U
    )  Pow U"
    unfolding lessThan_def greaterThan_def lessThan_ow_def greaterThan_ow_def
    by auto
  then have "topological_space_ow U τ'"
    unfolding τ' by (simp add: topological_space_generate_topology)
  moreover then have "s  U  τ' s = τ s" for s
    unfolding τ' using open_generated_order by blast
  ultimately show "topological_space_ow U τ"  
    unfolding τ' by (rule ts_open_eq_ts_open)
qed

end

locale ts_ot_ow = 
  ts: topological_space_ow U1 τ1 + ot: order_topology_ow U2 le2 ls2 τ2
  for U1 :: "'at set" and τ1 and U2 :: "'bt set" and le2 ls2 τ2
begin

sublocale topological_space_pair_ow U1 τ1 U2 τ2 ..

end

locale order_topology_pair_ow = 
  ot1: order_topology_ow U1 le1 ls1 τ1 + ot2: order_topology_ow U2 le2 ls2 τ2
  for U1 :: "'at set" and le1 ls1 τ1 and U2 :: "'bt set" and le2 ls2 τ2
begin

sublocale ts_ot_ow U1 τ1 U2 le2 ls2 τ2 ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma order_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (rel_set A ===> (=)) ===> 
      (=)
    ) (order_topology_ow (Collect (Domainp A))) class.order_topology"
  unfolding order_topology_ow_def class.order_topology_def
  unfolding order_topology_ow_axioms_def class.order_topology_axioms_def
proof(intro rel_funI, standard; elim conjE)
  let ?U = "Collect (Domainp A)"
  fix le :: "['a, 'a]  bool" 
    and le' :: "['b, 'b]  bool"
    and ls :: "['a, 'a]  bool" 
    and ls' :: "['b, 'b]  bool"
    and τ :: "'a set  bool"
    and τ' :: "'b set  bool"
  assume [transfer_rule]: "(A ===> A ===> (=)) le le'" 
    and [transfer_rule]: "(A ===> A ===> (=)) ls ls'"
    and [transfer_rule]: "(rel_set A ===> (=)) τ τ'"
    and oow: "order_ow (Collect (Domainp A)) le ls"
    and τ: 
      "sCollect (Domainp A). τ s =
        generate_topology_on
          (lessThan_ow ?U ls ` ?U  greaterThan_ow ?U ls ` ?U) ?U s" 
  have [transfer_rule]: "Domainp A = (λx. x  Collect (Domainp A))" by auto
  interpret oow: order_ow ?U le ls by (rule oow)
  interpret co: order le' ls' by transfer (rule oow)
  have ineq_fold:
    "lessThan.with ls y  {x. ls x y}" 
    "greaterThan.with ls y  {x. ls y x}"
    for ls :: "'c  'c  bool" and y 
    unfolding lessThan.with_def greaterThan.with_def by auto
  have 
    "τ' = generate_topology (
      range (ord.lessThan ls')  range (ord.greaterThan ls')
      )"
    unfolding co.lessThan_def co.greaterThan_def
    unfolding ineq_fold[symmetric]
    by (transfer, intro allI impI) (auto simp: τ)    
  from co.order_axioms this show
    "class.order le' ls'  
      τ' = generate_topology (
        range (ord.lessThan ls')  range (ord.greaterThan ls')
      )"
    by simp
next
  let ?U = "Collect (Domainp A)"
  fix le :: "['a, 'a]  bool" 
    and le' :: "['b, 'b]  bool"
    and ls :: "['a, 'a]  bool" 
    and ls' :: "['b, 'b]  bool"
    and τ :: "'a set  bool"
    and τ' :: "'b set  bool"
  assume [transfer_rule]: "(A ===> A ===> (=)) le le'" 
    and [transfer_rule]: "(A ===> A ===> (=)) ls ls'"
    and [transfer_rule]: "(rel_set A ===> (=)) τ τ'"
    and co: "class.order le' ls'"
    and τ': "τ' = generate_topology
      (range (ord.lessThan ls')  range (ord.greaterThan ls'))"
  have [transfer_rule]: "Domainp A = (λx. x  Collect (Domainp A))" by auto
  interpret co: order le' ls' by (rule co)
  have ineq_fold:
    "lessThan.with ls y  {x. ls x y}" 
    "greaterThan.with ls y  {x. ls y x}"
    for ls :: "'c  'c  bool" and y 
    unfolding lessThan.with_def greaterThan.with_def by auto
  from co have "order_ow ?U le ls" by transfer
  moreover have 
    "sCollect (Domainp A). τ s =
      SML_Topological_Space.generate_topology_on
        (lessThan_ow ?U ls ` ?U  greaterThan_ow ?U ls ` ?U) ?U s"
    by 
      (
        rule τ'[
          unfolded co.lessThan_def co.greaterThan_def,
          folded ineq_fold,
          untransferred
          ]
       )
  ultimately show 
    "order_ow ?U le ls 
      (
        sCollect (Domainp A). τ s = 
          SML_Topological_Space.generate_topology_on
            (lessThan_ow ?U ls ` ?U  greaterThan_ow ?U ls ` ?U) ?U s
      )"
    by simp
qed
  
end


subsubsection‹Relativization›

context order_topology_ow 
begin

tts_context
  tts: (?'a to U)
  substituting order_topology_ow_axioms
  eliminating ?U  {} through simp
begin

tts_lemma open_greaterThan:
  assumes "a  U"
  shows "τ {a<ow..}"
    is order_topology_class.open_greaterThan.
    
tts_lemma open_lessThan:
  assumes "a  U"
  shows "τ {..<owa}"
  is order_topology_class.open_lessThan.

tts_lemma open_greaterThanLessThan:
  assumes "a  U" and "b  U"
  shows "τ {a<ow..<owb}"
    is order_topology_class.open_greaterThanLessThan.

end

end



subsection‹Linearly ordered topological space›


subsubsection‹Definitions and common properties›

locale linorder_topology_ow = 
  linorder_ow U le ls + order_topology_ow U le ls τ 
  for U :: "'at set" and le ls τ

locale ts_lt_ow = 
  ts: topological_space_ow U1 τ1 + lt: linorder_topology_ow U2 le2 ls2 τ2
  for U1 :: "'at set" and τ1 and U2 :: "'bt set" and le2 ls2 τ2
begin

sublocale ts_ot_ow U1 τ1 U2 le2 ls2 τ2 ..

end

locale ot_lt_ow = 
  ot: order_topology_ow U1 le1 ls1 τ1 + lt: linorder_topology_ow U2 le2 ls2 τ2
  for U1 :: "'at set" and le1 ls1 τ1 and U2 :: "'bt set" and le2 ls2 τ2
begin

sublocale ts_lt_ow U1 τ1 U2 le2 ls2 τ2 ..
sublocale order_topology_pair_ow U1 le1 ls1 τ1 U2 le2 ls2 τ2 ..

end

locale linorder_topology_pair_ow = 
  lt1: linorder_topology_ow U1 le1 ls1 τ1 + lt2: linorder_topology_ow U2 le2 ls2 τ2
  for U1 :: "'at set" and le1 ls1 τ1 and U2 :: "'bt set" and le2 ls2 τ2
begin

sublocale ot_lt_ow U1 le1 ls1 τ1 U2 le2 ls2 τ2 ..

end


subsubsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma linorder_topology_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(
      (A ===> A ===> (=)) ===> 
      (A ===> A ===> (=)) ===> 
      (rel_set A ===> (=)) ===> 
      (=)
    ) 
    (linorder_topology_ow (Collect (Domainp A))) class.linorder_topology"
  unfolding linorder_topology_ow_def class.linorder_topology_def
  by transfer_prover

end


subsubsection‹Relativization›

context linorder_topology_ow 
begin

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting linorder_topology_ow_axioms
  eliminating ?U  {} through clarsimp
begin

tts_lemma open_right:
  assumes "S  U"
    and "x  U"
    and "y  U"
    and "τ S"
    and "x  S"
    and "x <ow y"
  shows "zU. x <ow z  (on U with (≤ow) (<ow) : {x..<z})  S"
    is linorder_topology_class.open_right.
    
tts_lemma open_left:
  assumes "S  U"
    and "x  U"
    and "y  U"
    and "τ S"
    and "x  S"
    and "y <ow x"
  shows "zU. z <ow x  {z<ow..x}  S"
    is linorder_topology_class.open_left.

tts_lemma connectedD_interval:
  assumes "U  U"
    and "x  U"
    and "y  U"
    and "z  U"
    and "connected U"
    and "x  U"
    and "y  U"
    and "x ow z"
    and "z ow y"
  shows "z  U"
    is linorder_topology_class.connectedD_interval.

tts_lemma connected_contains_Icc:
  assumes "A  U"
    and "a  U"
    and "b  U"
    and "connected A"
    and "a  A"
    and "b  A"
  shows "{a..owb}  A"
    is Topological_Spaces.connected_contains_Icc.

tts_lemma connected_contains_Ioo:
  assumes "A  U"
    and "a  U"
    and "b  U"
    and "connected A"
    and "a  A"
    and "b  A"
  shows "{a<ow..<owb}  A"
    is Topological_Spaces.connected_contains_Ioo.

end

tts_context
  tts: (?'a to U) 
  rewriting ctr_simps
  substituting linorder_topology_ow_axioms
  eliminating ?U  {} through clarsimp
begin

tts_lemma not_in_connected_cases:
  assumes "S  U"
    and "x  U"
    and "connected S"
    and "x  S"
    and "S  {}"
    and "bdd_above S; y. y  U; y  S  y ow x  thesis"
    and "bdd_below S; y. y  U; y  S  x ow y  thesis"
  shows thesis
    is linorder_topology_class.not_in_connected_cases.

tts_lemma compact_attains_sup:
  assumes "S  U"
    and "compact S"
    and "S  {}"
  shows "xS. yS. y ow x"
    is linorder_topology_class.compact_attains_sup.

tts_lemma compact_attains_inf:
  assumes "S  U"
    and "compact S"
    and "S  {}"
  shows "xS. Ball S ((≤ow) x)"
    is linorder_topology_class.compact_attains_inf.

end

end

text‹\newpage›

end

Theory SML_Product_Topology

(* Title: Examples/SML_Relativization/Topology/SML_Product_Topology.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Relativization of the results about product topologies›
theory SML_Product_Topology
  imports 
    SML_Topological_Space
    "../Foundations/Product_Type_Ext"
begin



subsection‹Definitions and common properties›

ud‹
  open_prod_inst.open_prod::
    ('a::topological_space × 'b::topological_space) set  _
ud‹open::('a::topological_space × 'b::topological_space) set  bool›

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: 
    "Domainp B = (λx. x  U1)" "Domainp A = (λx. x  U2)"
    and [transfer_rule]: "bi_unique A" "right_total A"
      "bi_unique B" "right_total B"
  trp (?'a A) and (?'b B) 
  in open_ow: open_prod.with_def
    ('(/on _ _ with _ _ : «open» _/') [1000, 999, 1000, 999, 1000] 10) 

locale product_topology_ow =
  ts1: topological_space_ow U1 τ1 + ts2: topological_space_ow U2 τ2 
  for U1 :: "'at set" and τ1 :: "'at set  bool" 
    and U2 :: "'bt set"and τ2 :: "'bt set  bool" +
  fixes τ :: "('at × 'bt) set  bool"
  assumes open_prod[tts_implicit]: "τ = open_ow U1 U2 τ2 τ1"
begin 

sublocale topological_space_ow U1 × U2 τ
proof
  let ?U = "U1 × U2"  
  have open_prod': "τ S = open_ow U1 U2 τ2 τ1 S" for S
    by (simp only: open_prod)
  note op = open_prod'[unfolded open_ow_def, THEN iffD2, rule_format]
  show "τ (U1 × U2)" by (rule op) auto   
  show " S  ?U; T  ?U; τ S; τ T   τ (S  T)" for S T
  proof-
    assume "S  ?U" and "T  ?U" and "τ S" and "τ T"
    from S  ?U T  ?U have "S  T  ?U" by auto
    show "τ (S  T)"
    proof(rule op)
      fix x assume "x  S  T"
      then have "x  S" and "x  T" by auto
      from open_prod'[
          unfolded open_ow_def, THEN iffD1, rule_format, OF τ S x  S
          ]
      obtain AS BS where 
        "AS  U1" "BS  U2" "τ1 AS" "τ2 BS" "x  AS × BS" "AS × BS  S" 
        by auto 
      from open_prod'[
          unfolded open_ow_def, THEN iffD1, rule_format, 
          OF τ T x  T
          ]
      obtain AT BT where 
        "AT  U1" "BT  U2" "τ1 AT" "τ2 BT" "x  AT × BT" "AT × BT  T" 
        by auto
      from AS  U1 AT  U1 have "AS  AT  U1" by auto
      moreover from BS  U2 BT  U2 have "BS  BT  U2" by auto
      moreover from AS  U1 AT  U1 τ1 AS τ1 AT have "τ1 (AS  AT)" 
        by auto
      moreover from BS  U2 BT  U2 τ2 BS τ2 BT have "τ2 (BS  BT)" 
        by auto
      moreover from x  AS × BS x  AT × BT have 
        "x  (AS  AT) × (BS  BT)"
        by clarsimp
      moreover from AS × BS  S AT × BT  T have 
        "(AS  AT) × (BS  BT)  S  T"
        by auto
      ultimately show 
        "APow U1. BPow U2. τ1 A  τ2 B  A × B  S  T  x  A × B" 
        by auto
    qed
  qed
  show " K  Pow ?U; SK. τ S   τ (K)" for K
  proof -
    assume "K  Pow ?U" and "SK. τ S" 
    from K  Pow ?U have "K  ?U" by auto
    show "τ (K)"
    proof(rule op)
      fix x assume "x  K"
      then obtain k where k: "x  k" and "k  K" by clarsimp
      from k  K have "k  K" by auto
      from k  K have "τ k" by (rule SK. τ S[rule_format])
      from open_prod'[
          unfolded open_ow_def, THEN iffD1, rule_format,
          OF this x  k
          ]
      obtain A B where 
        "A  U1" "B  U2" "τ1 A" "τ2 B" "x  A × B" "A × B  k"
        by auto
      from A × B  k k  K have "A × B  K" by simp
      from A  U1 B  U2 τ1 A τ2 B x  A × B this show 
        " APow U1. BPow U2. τ1 A  τ2 B  A × B   K  x  A × B"
        by auto
    qed
  qed
qed

end



subsection‹Transfer rules›

lemma (in product_topology_ow) open_with_oo_transfer[transfer_rule]:
  includes lifting_syntax
  fixes A :: "['at, 'a]  bool"
    and B :: "['bt, 'b]  bool"
  assumes tdr_U1[transfer_domain_rule]: "Domainp A = (λx. x  U1)"
    and [transfer_rule]: "bi_unique A" "right_total A"  
    and tdr_U2[transfer_domain_rule]: "Domainp B = (λx. x  U2)"
    and [transfer_rule]: "bi_unique B" "right_total B" 
    and τ1τ1'[transfer_rule]: "(rel_set A ===> (=)) τ1 τ1'"
    and τ2τ2'[transfer_rule]: "(rel_set B ===> (=)) τ2 τ2'"
  shows "(rel_set (rel_prod A B) ===> (=)) τ (open_prod.with τ2' τ1')"
  unfolding open_prod.with_def
  apply transfer_prover_start
  apply transfer_step+
  apply simp
  apply(fold subset_eq)
  unfolding open_prod open_ow_def tdr_U1 tdr_U2 
  by (meson Pow_iff)



subsection‹Relativization›

context product_topology_ow
begin

tts_context
  tts: (?'a to U1) and (?'b to U2)
  rewriting ctr_simps
  substituting ts1.topological_space_ow_axioms 
    and ts2.topological_space_ow_axioms
  eliminating ?U  {} through (fold tts_implicit, insert closed_empty, simp)
  applying [folded tts_implicit]
begin

tts_lemma open_prod_intro:
  assumes "S  U1 × U2"
    and "x. x  U1 × U2; x  S  
      APow U1. BPow U2. τ1 A  τ2 B  A × B  S  x  A × B"
  shows "τ S"
    is open_prod_intro.

tts_lemma open_Times:
  assumes "S  U1" and "T  U2" and "τ1 S" and "τ2 T"
  shows "τ (S × T)"
    is open_Times.
    
tts_lemma open_vimage_fst:
  assumes "S  U1" and "τ1 S"
  shows "τ (fst -` S  U1 × U2)"
    is open_vimage_fst.

tts_lemma closed_vimage_fst:
  assumes "S  U1" and "ts1.closed S"
  shows "closed (fst -` S  U1 × U2)"
    is closed_vimage_fst.

tts_lemma closed_Times:
  assumes "S  U1" and "T  U2" and "ts1.closed S" and "ts2.closed T"
  shows "closed (S × T)"
    is closed_Times.

tts_lemma open_image_fst:
  assumes "S  U1 × U2" and "τ S"
  shows "τ1 (fst ` S)"
    is open_image_fst.

tts_lemma open_image_snd:
  assumes "S  U1 × U2" and "τ S"
  shows "τ2 (snd ` S)"
    is open_image_snd.

end

tts_context
  tts: (?'a to U1) and (?'b to U2)
  rewriting ctr_simps
  substituting ts1.topological_space_ow_axioms 
    and ts2.topological_space_ow_axioms
  eliminating ?U  {} 
    through (fold tts_implicit, unfold connected_ow_def, simp)
  applying [folded tts_implicit]
begin

tts_lemma connected_Times:
  assumes "S  U1" and "T  U2" and "ts1.connected S" and "ts2.connected T"
  shows "connected (S × T)"
    is connected_Times.
    
tts_lemma connected_Times_eq:
  assumes "S  U1" and "T  U2"
  shows 
    "connected (S × T) = (S = {}  T = {}  ts1.connected S  ts2.connected T)"
  is connected_Times_eq.

end

tts_context
  tts: (?'b to U1) and (?'a to U2)
  rewriting ctr_simps
  substituting ts1.topological_space_ow_axioms 
    and ts2.topological_space_ow_axioms
  eliminating ?U  {} through (fold tts_implicit, insert closed_empty, simp)
  applying [folded tts_implicit]
begin

tts_lemma open_vimage_snd:
  assumes "S  U2" and "τ2 S"
  shows "τ (snd -` S  U1 × U2)"
    is open_vimage_snd.

tts_lemma closed_vimage_snd:
  assumes "S  U2" and "ts2.closed S"
  shows "closed (snd -` S  U1 × U2)"
    is closed_vimage_snd.

end

end

text‹\newpage›

end

Theory VS_Prerequisites

(* Title: Examples/Vector_Spaces/VS_Prerequisites.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
chapter‹TTS Vector Spaces›
theory VS_Prerequisites
  imports Types_To_Sets_Extension.ETTS_Auxiliary
begin




section‹Introduction›



subsection‹Background›


text‹
The content of this chapter is an adoption of the applied relativization
study presented in \cite{immler_smooth_2019} to the ETTS. 
The content of this chapter incorporates 
many elements of the content of aforementioned relativization study without 
an explicit reference. Nonetheless, no attempt was made to ensure that
the theorems obtained as a result of this work are identical to the theorems 
obtained in \cite{immler_smooth_2019}. 
›



subsection‹Prerequisites›

ctr parametricity
  in bij_betw_ow: bij_betw_def

lemma bij_betw_parametric'[transfer_rule]:
  includes lifting_syntax
  assumes "bi_unique A"
  shows "((A ===> A) ===> rel_set A ===> rel_set A ===> (=)) 
    bij_betw bij_betw"
  by (rule bij_betw_ow.transfer[OF assms assms])

lemma vimage_transfer[transfer_rule]: 
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique B" "right_total A" 
  shows 
    "((A ===> B) ===> (rel_set B) ===> rel_set A) 
      (λf s. (vimage f s)  (Collect (Domainp A))) (-`)"
  by transfer_prover

lemma Eps_unique_transfer_lemma:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "right_total A" "(A ===> (=)) f g" "(A ===> (=)) f' g'"
    and holds: "x. Domainp A x  f x"
    and unique_g: "x y.  g x; g y   g' x = g' y"
  shows "f' (Eps (λx. Domainp A x  f x)) = g' (Eps g)"
proof -
  define Epsg where "Epsg = Eps g"
  have "x. g x" by transfer (simp add: holds)
  then have "g Epsg" unfolding Epsg_def by (rule someI_ex)
  obtain x where x[transfer_rule]: "A x Epsg" 
    by (meson ‹right_total A right_totalE)
  then have "Domainp A x" by auto
  from g Epsg[untransferred] have "f x" .
  from unique_g have unique:
    "x y.  Domainp A x; Domainp A y; f x; f y   f' x = f' y"
    by transfer
  have "f' (Eps (λx. Domainp A x  f x)) = f' x"
    by (rule unique[OF _ ‹Domainp A x _ f x]) 
      (metis (mono_tags, lifting) local.holds someI_ex)+
  show "f' (SOME x. Domainp A x  f x) = g' (Eps g)"
    using x f' (Eps _) = f' x Epsg_def rel_funE assms(3) by fastforce
qed

text‹\newpage›

end

Theory VS_Groups

(* Title: Examples/Vector_Spaces/VS_Groups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Groups›
theory VS_Groups
  imports VS_Prerequisites
begin



subsection‹Definitions and elementary properties›

locale semigroup_add_ow =
  fixes S :: "'a set" and pls :: "'a  'a  'a" (infixl ow 65)
  assumes add_assoc: 
    " a  S; b  S; c  S   (a ow b) ow c = a ow (b ow c)"
    and add_closed: " a  S; b  S   a ow b  S"
begin

lemma add_closed'[simp]: "xS. yS. x ow y  S" by (auto simp: add_closed)

end

locale ab_semigroup_add_ow = semigroup_add_ow +
  assumes add_commute: " a  S; b  S   a ow b = b ow a"

locale comm_monoid_add_ow = ab_semigroup_add_ow +
  fixes z
  assumes add_zero: "a  S  z ow a = a"
    and zero_closed[simp]: "z  S"
begin

lemma carrier_ne[simp]: "S  {}" using zero_closed by blast

end

definition "sum_with pls z f S =
  (
    if C. f ` S  C  comm_monoid_add_ow C pls z 
    then Finite_Set.fold (pls o f) z S 
    else z
  )"

lemma sum_with_empty[simp]: "sum_with pls z f {} = z"
  by (auto simp: sum_with_def)

lemma sum_with_cases[case_names comm zero]:
  assumes "C.  f ` S  C; comm_monoid_add_ow C pls z   
      P (Finite_Set.fold (pls o f) z S)"
    and "(C. comm_monoid_add_ow C pls z  (sS. f s  C))  P z"
  shows "P (sum_with pls z f S)"
  using assms by (auto simp: sum_with_def)

context comm_monoid_add_ow 
begin

lemma sum_with_infinite: "infinite A  sum_with (⊕ow) z g A = z"
  by (induction rule: sum_with_cases) auto

context 
begin

abbreviation pls' :: "'a  'a  'a"
  where "pls'  λx y. (if x  S then x else z) ow (if y  S then y else z)"

lemma fold_pls'_closed: "Finite_Set.fold (pls'  g) z A  S" if "g ` A  S"
proof cases
  assume A: "finite A"
  interpret comp_fun_commute "pls' o g"
    using that add_assoc add_commute add_closed zero_closed 
    by unfold_locales auto
  from fold_graph_fold[OF A] have 
    "fold_graph (pls'  g) z A (Finite_Set.fold (pls'  g) z A)" .
  from 
    fold_graph_closed_lemma[OF this, of S "pls'  g"]
    add_assoc 
    add_commute 
    add_closed 
    zero_closed
  show ?thesis
    by auto
qed (use add_assoc add_commute add_closed zero_closed in simp)

lemma fold_pls'_eq: 
  assumes "g ` A  S"
  shows "Finite_Set.fold (pls'  g) z A = Finite_Set.fold (pls  g) z A"
  using add_assoc add_commute add_closed zero_closed assms
  by (intro fold_closed_eq[where B=S]) auto

lemma sum_with_closed: 
  assumes "g ` A  S"
  shows "sum_with pls z g A  S" 
proof -
  interpret comp_fun_commute "pls' o g"
    using add_assoc add_commute add_closed zero_closed assms 
    by unfold_locales auto
  have "C. g ` A  C  comm_monoid_add_ow C pls z"
    using assms comm_monoid_add_ow_axioms by auto
  then show ?thesis
    using fold_pls'_closed[OF assms]
    by (simp add: sum_with_def fold_pls'_eq assms)
qed

lemma sum_with_insert:
  assumes g_into: "g x  S" "g ` A  S"
    and A: "finite A" 
    and x: "x  A"
  shows "sum_with pls z g (insert x A) = (g x) ow (sum_with pls z g A)"
proof -
  interpret comp_fun_commute "pls' o g"
    using add_assoc add_commute add_closed zero_closed g_into by unfold_locales auto
  have 
    "Finite_Set.fold (pls  g) z (insert x A) = 
      Finite_Set.fold (pls'  g) z (insert x A)"
    using g_into by (subst fold_pls'_eq) auto
  also have " = pls' (g x) (Finite_Set.fold (pls'  g) z A)"
    unfolding fold_insert[OF A x] by (auto simp: o_def)
  also have " = (g x) ow (Finite_Set.fold (pls'  g) z A)"
  proof -
    from fold_graph_fold[OF A] have 
      "fold_graph (pls'  g) z A (Finite_Set.fold (pls'  g) z A)" .
    from 
      fold_graph_closed_lemma[OF this, of S "pls'  g"] 
      add_assoc 
      add_commute 
      add_closed 
      zero_closed
    have "Finite_Set.fold (pls'  g) z A  S"
      by auto
    then show ?thesis using g_into by auto
  qed
  also have 
    "Finite_Set.fold (pls'  g) z A = Finite_Set.fold (pls  g) z A"
    using g_into by (subst fold_pls'_eq) auto
  finally have 
    "Finite_Set.fold (pls  g) z (insert x A) = 
      pls (g x) (Finite_Set.fold (pls  g) z A)" .
  moreover have 
    "C. g ` insert x A  C  comm_monoid_add_ow C pls z"
    "C. g ` A  C  comm_monoid_add_ow C pls z"
    using assms(1,2) comm_monoid_add_ow_axioms by auto
  ultimately show ?thesis by (simp add: sum_with_def)
qed

end

end

locale ab_group_add_ow = comm_monoid_add_ow +
  fixes mns um
  assumes ab_left_minus: "a  S  (um a) ow a = z"
    and ab_diff_conv_add_uminus: 
      " a  S; b  S   mns a b = a ow (um b)"
    and uminus_closed: "a  S  um a  S"



subsection‹Instances (by type class constraints)›

lemma semigroup_add_ow_Ball_def: 
  "semigroup_add_ow S pls 
  (aS. bS. cS. pls (pls a b) c = 
    pls a (pls b c))  (aS. bS. pls a b  S)"
  by (auto simp: semigroup_add_ow_def)

lemma ab_semigroup_add_ow_Ball_def:
  "ab_semigroup_add_ow S pls  
    semigroup_add_ow S pls  (aS. bS. pls a b = pls b a)"
  by  (auto simp: ab_semigroup_add_ow_def ab_semigroup_add_ow_axioms_def)

lemma comm_monoid_add_ow_Ball_def:
  "comm_monoid_add_ow S pls z  
    ab_semigroup_add_ow S pls  (aS. pls z a = a)  z  S"
  by (auto simp: comm_monoid_add_ow_def comm_monoid_add_ow_axioms_def)

lemma comm_monoid_add_ow[simp]: 
  "comm_monoid_add_ow UNIV (+) (0::'a::comm_monoid_add)"
  by 
    (
      auto simp: 
        comm_monoid_add_ow_Ball_def 
        ab_semigroup_add_ow_Ball_def
        semigroup_add_ow_Ball_def 
        ac_simps
    )

lemma ab_group_add_ow_Ball_def:
  "ab_group_add_ow S pls z mns um  
    comm_monoid_add_ow S pls z 
    (aS. pls (um a) a = z)  
    (aS. bS. mns a b = pls a (um b))  
    (aS. um a  S)"
  by (auto simp: ab_group_add_ow_def ab_group_add_ow_axioms_def)

lemma sum_with[ud_with]: "sum = sum_with (+) 0"
proof(intro HOL.ext)
  fix f :: "'a  'b" and S :: "'a set" 
  show "sum f S = sum_with (+) 0 f S"
  proof(induction rule: sum_with_cases)
    case (comm C) then show ?case unfolding sum.eq_fold by simp
  next
    case zero from zero[OF comm_monoid_add_ow] show ?case by simp
  qed
qed

lemmas [tts_implicit] = sum_with[symmetric]



subsection‹Transfer rules›

context
  includes lifting_syntax
begin

lemma semigroup_add_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> (A ===> A ===> A) ===> (=)) 
    semigroup_add_ow semigroup_add_ow"
  unfolding semigroup_add_ow_Ball_def
  by transfer_prover

lemma Domainp_applyI:
  includes lifting_syntax
  shows "(A ===> B) f g  A x y  Domainp B (f x)"
  by (auto simp: rel_fun_def)

lemma Domainp_apply2I:
  includes lifting_syntax
  shows "(A ===> B ===> C) f g  A x y  B x' y'  Domainp C (f x x')"
  by (force simp: rel_fun_def)

lemma ab_semigroup_add_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows
    "(rel_set A ===> (A ===> A ===> A) ===> (=)) 
      ab_semigroup_add_ow ab_semigroup_add_ow"
  unfolding ab_semigroup_add_ow_Ball_def by transfer_prover

lemma right_total_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "((A ===> A ===> A) ===> (=)) 
    (semigroup_add_ow (Collect (Domainp A))) class.semigroup_add"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_add_ow = "(λf. semigroup_add_ow (Collect (Domainp A)) f)"
  let ?rf_UNIV = 
    "(λf::['b, 'b]  'b. (x y. x  UNIV  y  UNIV  f x y  UNIV))"
  have "?P ?semigroup_add_ow (λf. ?rf_UNIV f  class.semigroup_add f)"
    unfolding semigroup_add_ow_def class.semigroup_add_def
    apply transfer_prover_start
    apply transfer_step+
    by auto
  thus ?thesis by simp
qed

lemma comm_monoid_add_on_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A"
  shows
    "(rel_set A ===> (A ===> A ===> A) ===> A ===> (=)) 
      comm_monoid_add_ow comm_monoid_add_ow"
  unfolding comm_monoid_add_ow_Ball_def by transfer_prover

lemma right_total_ab_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows
    "((A ===> A ===> A) ===> (=)) 
      (ab_semigroup_add_ow (Collect (Domainp A))) class.ab_semigroup_add"
  unfolding 
    class.ab_semigroup_add_def 
    class.ab_semigroup_add_axioms_def 
    ab_semigroup_add_ow_Ball_def
  by transfer_prover

lemma right_total_comm_monoid_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows "((A ===> A ===> A) ===> A ===> (=))
    (comm_monoid_add_ow (Collect (Domainp A))) class.comm_monoid_add" 
proof(intro rel_funI)
  fix p p' z z'
  assume [transfer_rule]: "(A ===> A ===> A) p p'" "A z z'"
  show 
    "comm_monoid_add_ow (Collect (Domainp A)) p z = 
      class.comm_monoid_add p' z'"
    unfolding 
      class.comm_monoid_add_def 
      class.comm_monoid_add_axioms_def 
      comm_monoid_add_ow_Ball_def
    apply transfer
    using A z z'
    by auto
qed

lemma ab_group_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows 
    "((A ===> A ===> A) ===> A  ===> (A ===> A ===> A) ===> (A ===> A)===> (=))
      (ab_group_add_ow (Collect (Domainp A))) class.ab_group_add"
proof (intro rel_funI)
  fix p p' z z' m m' um um'
  assume [transfer_rule]:
    "(A ===> A ===> A) p p'" "A z z'" "(A ===> A ===> A) m m'"
    and um[transfer_rule]: "(A ===> A) um um'"
  show 
    "ab_group_add_ow (Collect (Domainp A)) p z m um = 
      class.ab_group_add p' z' m' um'"
    unfolding 
      class.ab_group_add_def 
      class.ab_group_add_axioms_def 
      ab_group_add_ow_Ball_def
    by transfer (use um in auto simp: rel_fun_def›)
qed

lemma ex_comm_monoid_add_around_imageE:
  assumes ex_comm: "C. f ` S  C  comm_monoid_add_ow C pls zero"
    and transfers: 
    "(A ===> A ===> A) pls pls'" 
    "A zero zero'" 
    "Domainp (rel_set B) S"
    and in_dom: "x. x  S  Domainp A (f x)"
  obtains C where 
    "comm_monoid_add_ow C pls zero" "f ` S  C" "Domainp (rel_set A) C"
proof -
  from ex_comm obtain C0 where C0: "f ` S  C0" 
    and comm: "comm_monoid_add_ow C0 pls zero"
    by auto
  define C where "C = C0  Collect (Domainp A)"
  have "comm_monoid_add_ow C pls zero"
    using comm Domainp_apply2I[OF (A ===> A ===> A) pls pls'] A zero zero'
    by 
      (
        auto simp: 
          comm_monoid_add_ow_Ball_def 
          ab_semigroup_add_ow_Ball_def
          semigroup_add_ow_def 
          C_def
      )
  moreover have "f ` S  C" using C0 by (auto simp: C_def in_dom)
  moreover have "Domainp (rel_set A) C" by (auto simp: C_def Domainp_set)
  ultimately show ?thesis ..
qed

lemma Domainp_sum_with:
  includes lifting_syntax
  assumes "x. x  t  Domainp A (r x)" "t  Collect (Domainp A)"
    and transfer_rules[transfer_rule]: "(A ===> A ===> A) p p'" "A z z'" 
  shows DsI: "Domainp A (sum_with p z r t)" 
proof cases
    assume ex: "C. r ` t  C  comm_monoid_add_ow C p z"
    have "Domainp (rel_set A) t" using assms by (auto simp: Domainp_set)
    from ex_comm_monoid_add_around_imageE[
        OF ex transfer_rules(1,2) this assms(1)
        ]
    obtain C where C: 
      "comm_monoid_add_ow C p z" "r ` t  C" "Domainp (rel_set A) C" 
      by auto
    interpret comm_monoid_add_ow C p z by fact
    from sum_with_closed[OF C(2)] C(3)
    show ?thesis by auto (meson C(3) Domainp_set)
qed (use A z _ in auto simp: sum_with_def›)

lemma sum_with_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique A" "bi_unique B"
  shows "((A ===> A ===> A) ===> A ===> (B ===> A) ===> rel_set B ===> A)
    sum_with sum_with"
proof(intro rel_funI)
  fix pls pls' zero zero' f g S T
  assume transfer_pls[transfer_rule]: "(A ===> A ===> A) pls pls'"
    and transfer_zero[transfer_rule]: "A zero zero'"
  assume transfer_g[transfer_rule]: "(B ===> A) f g"
    and transfer_T[transfer_rule]: "rel_set B S T"
  show "A (sum_with pls zero f S) (sum_with pls' zero' g T)"
  proof cases
    assume ex_comm: "C. f ` S  C  comm_monoid_add_ow C pls zero"
    have Domains: "Domainp (rel_set B) S" "(x. x  S  Domainp A (f x))"
      using transfer_T transfer_g by auto (meson Domainp_applyI rel_set_def)
    from ex_comm_monoid_add_around_imageE[
        OF ex_comm transfer_pls transfer_zero Domains
        ]
    obtain C where comm: "comm_monoid_add_ow C pls zero"
      and C: "f ` S  C"
      and "Domainp (rel_set A) C"
      by auto
    then obtain C' where [transfer_rule]: "rel_set A C C'" by auto
    interpret comm: comm_monoid_add_ow C pls zero by fact
    have C': "g ` T  C'" by transfer (rule C)
    have comm': "comm_monoid_add_ow C' pls' zero'" by transfer (rule comm)
    then interpret comm': comm_monoid_add_ow C' pls' zero' .
    from C' comm' have ex_comm': 
      "C. g ` T  C  comm_monoid_add_ow C pls' zero'" 
      by auto
    show ?thesis
      using transfer_T C C'
    proof (induction S arbitrary: T rule: infinite_finite_induct)
      case (infinite S)
      note [transfer_rule] = infinite.prems
      from infinite.hyps have "infinite T" by transfer
      then show ?case by (simp add: sum_with_def infinite.hyps A zero zero')
    next
      case [transfer_rule]: empty
      have "T = {}" by transfer rule
      then show ?case by (simp add: sum_with_def A zero zero')
    next
      case (insert x F)
      note [transfer_rule] = insert.prems(1)
      have [simp]: "finite T" by transfer (simp add: insert.hyps)
      obtain y where [transfer_rule]: "B x y" and y: "y  T"
        by (meson insert.prems insertI1 rel_setD1)
      define T' where "T' = T - {y}"
      have T_def: "T = insert y T'" by (auto simp: T'_def y)
      define sF where "sF = sum_with pls zero f F"
      define sT where "sT = sum_with pls' zero' g T'"
      have [simp]: "y  T'" "finite T'" by (auto simp: y T'_def)
      have "rel_set B (insert x F - {x}) T'"
        unfolding T'_def by transfer_prover
      then have transfer_T'[transfer_rule]: "rel_set B F T'"
        using insert.hyps by simp
      from insert.prems have "f ` F  C" "g ` T'  C'" by (auto simp: T'_def)
      from insert.IH[OF transfer_T' this] have [transfer_rule]: "A sF sT" 
        by (auto simp: sF_def sT_def o_def)
      have rew: 
        "(sum_with pls zero f (insert x F)) = 
          pls (f x) (sum_with pls zero f F)"
        apply (subst comm.sum_with_insert)
        subgoal using insert.prems by auto
        subgoal using insert.prems by auto
        subgoal by fact
        subgoal by fact
        subgoal by auto
        done
      have rew': 
        "(sum_with pls' zero' g (insert y T')) = 
          pls' (g y) (sum_with pls' zero' g T')"
        apply (subst comm'.sum_with_insert)
        subgoal
          apply transfer
          using insert.prems by auto
        subgoal
          apply transfer
          using insert.prems by auto
        subgoal by fact
        subgoal by fact
        subgoal by auto
        done
      have 
        "A 
          (sum_with pls zero f (insert x F)) 
          (sum_with pls' zero' g (insert y T'))"
        unfolding sT_def[symmetric] sF_def[symmetric] rew rew'
        by transfer_prover
      then show ?case by (simp add: T_def)
    qed
  next
    assume *: "C. f ` S  C  comm_monoid_add_ow C pls zero"
    then have **: "C'. g ` T  C'  comm_monoid_add_ow C' pls' zero'"
      by transfer simp
    show ?thesis by (simp add: sum_with_def * ** A zero zero')
  qed
qed

end



subsection‹Relativization.›

context ab_group_add_ow
begin

tts_context
  tts: (?'a to S) 
  rewriting ctr_simps
  substituting comm_monoid_add_ow_axioms
  eliminating S  {} through auto
  applying [OF add_closed' zero_closed]
begin

tts_lemma mono_neutral_cong_left:
  assumes "range h  S"
    and "range g  S"
    and "finite T"
    and "Sa  T"
    and "xT - Sa. h x = z"
    and "x. x  Sa  g x = h x"
  shows "sum_with (⊕ow) z g Sa = sum_with (⊕ow) z h T"
    is sum.mono_neutral_cong_left.

end

end

text‹\newpage›

end

Theory VS_Modules

(* Title: Examples/Vector_Spaces/VS_Modules.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Modules›
theory VS_Modules
  imports 
    VS_Groups
    Complex_Main
begin



subsectiontext‹module_with›

locale module_with = ab_group_add plusM zeroM minusM uminusM
  for plusM :: "['m, 'm]  'm" (infixl +M 65)
    and zeroM (0M)
    and minusM (infixl -M 65)
    and uminusM (-M _› [81] 80) +
  fixes scale :: "['cr1::comm_ring_1, 'm]  'm" (infixr "*swith" 75)
  assumes scale_right_distrib[algebra_simps]: 
    "a *swith (x +M y) = a *swith x +M a *swith y"
    and scale_left_distrib[algebra_simps]:
      "(a + b) *swith x = a *swith x +M b *swith x"
    and scale_scale[simp]: "a *swith (b *swith x) = (a * b) *swith x"
    and scale_one[simp]: "1 *swith x = x"

lemma module_with_overloaded[ud_with]: "module = module_with (+) 0 (-) uminus"
  unfolding module_def module_with_def module_with_axioms_def
  by (simp add: comm_ring_1_axioms ab_group_add_axioms)

locale module_pair_with =
  M1: module_with plusM_1 zeroM_1 minusM_1 uminusM_1 scale1 +
  M2: module_with plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
  for plusM_1 :: "['m_1, 'm_1]  'm_1" (infixl +M'_1 65)
    and zeroM_1 (0M'_1)
    and minusM_1 (infixl -M'_1 65)
    and uminusM_1 (-M'_1 _› [81] 80)
    and scale1 (infixr *swith'_1 75)
    and plusM_2 :: "['m_2, 'm_2]  'm_2" (infixl +M'_2 65)
    and zeroM_2 (0M'_2)
    and minusM_2 (infixl -M'_2 65)
    and uminusM_2 (-M'_2 _› [81] 80)
    and scale2 (infixr *swith'_2 75)

lemma module_pair_with_overloaded[ud_with]: 
  "
  module_pair = 
    (
      λscale1 scale2. 
        module_pair_with (+) 0 (-) uminus scale1 (+) 0 (-) uminus scale2
    )
  "
  unfolding module_pair_def module_pair_with_def 
  unfolding module_with_overloaded
  ..

locale module_hom_with = 
  M1: module_with plusM_1 zeroM_1 minusM_1 uminusM_1 scale1 +
  M2: module_with plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
  for plusM_1 :: "['m_1, 'm_1]  'm_1" (infixl +M'_1 65)
    and zeroM_1 (0M'_1)
    and minusM_1 (infixl -M'_1 65)
    and uminusM_1 (-M'_1 _› [81] 80)
    and scale1 (infixr *swith'_1 75)
    and plusM_2 :: "['m_2, 'm_2]  'm_2" (infixl +M'_2 65)
    and zeroM_2 (0M'_2)
    and minusM_2 (infixl -M'_2 65)
    and uminusM_2 (-M'_2 _› [81] 80)
    and scale2 (infixr *swith'_2 75) +
  fixes f :: "'m_1  'm_2"
  assumes add: "f (b1 +M_1 b2) = f b1 +M_2 f b2"
    and scale: "f (r *swith_1 b) = r *swith_2 f b"
begin

sublocale module_pair_with ..

end

lemma module_hom_with_overloaded[ud_with]: 
  "module_hom =
    (
      λscale1 scale2.
        module_hom_with (+) 0 (-) uminus scale1 (+) 0 (-) uminus scale2
    )"
  unfolding 
    module_hom_def module_hom_axioms_def 
    module_hom_with_def module_hom_with_axioms_def
  unfolding module_with_overloaded
  ..
ud ‹module.subspace› ((with _ _ _ : «subspace» _) [1000, 999, 998, 1000] 10)
ud ‹module.span› ((with _ _ _ : «span» _) [1000, 999, 998, 1000] 10)
ud ‹module.dependent› 
  ((with _ _ _ _ : «dependent» _) [1000, 999, 998, 997, 1000] 10)
ud ‹module.representation› 
  (
    (with _ _ _ _ : «representation» _ _) 
    [1000, 999, 998, 997, 1000, 999] 10
  )

abbreviation independent_with 
  ((with _ _ _ _ : «independent» _) [1000, 999, 998, 997, 1000] 10)
  where 
    "(with zeroCR1 zeroM  scaleM plusM : «independent» s) 
      ¬(with zeroCR1 zeroM scaleM plusM : «dependent» s)"

lemma span_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows 
    "(
      A ===> 
      (A ===> A ===> A) ===>
      ((=) ===> A ===> A) ===> 
      rel_set A ===> 
      rel_set A
    ) span.with span.with"
  unfolding span.with_def
proof(intro rel_funI)
  fix p p' z z' X X' and s s'::"'c  _"
  assume transfer_rules[transfer_rule]:   
    "(A ===> A ===> A) p p'" 
    "A z z'" 
    "((=) ===> A ===> A) s s'" 
    "rel_set A X X'"
  have "Domainp A z" using A z z' by force
  have *: "t  X  (xt. Domainp A x)" for t
    by (meson Domainp.DomainI ‹rel_set A X X' rel_setD1 subsetD)
  note swt = sum_with_transfer
    [
      OF assms(1,2,2), 
      THEN rel_funD, 
      THEN rel_funD, 
      THEN rel_funD,  
      THEN rel_funD,  
      OF transfer_rules(1,2)
    ]
  have DsI: "Domainp A (sum_with p z r t)" 
    if "x. x  t  Domainp A (r x)" "t  Collect (Domainp A)" for r t
    by (metis that Domainp_sum_with transfer_rules(1,2))
  from Domainp_apply2I[OF transfer_rules(3)]
  have Domainp_sI: "Domainp A x  Domainp A (s y x)" for x y by auto
  show "rel_set A
    {sum_with p z (λa. s (r a) a) t |t r. finite t  t  X}
        {sum_with p' z' (λa. s' (r a) a) t |t r. finite t  t  X'}"
    apply transfer_prover_start 
    apply transfer_step+
    by (insert *) (auto intro!: DsI Domainp_sI)
qed

lemma dependent_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  shows 
    "(
      (=) ===>
      A ===> 
      (A ===> A ===> A) ===>
      ((=) ===> A ===> A) ===> 
      rel_set A ===> 
      (=)
    ) dependent.with dependent.with"
  unfolding dependent.with_def 
proof(intro rel_funI)
  fix p p' z z' X X' and zb zb' ::'c and s s'::"'c  _"
  assume [transfer_rule]: 
    "(A ===> A ===> A) p p'"
    "A z z'"
    "zb = zb'"
    "((=) ===> A ===> A) s s'" 
    "rel_set A X X'"
  have *: "t  X  (xt. Domainp A x)" for t
    by (meson Domainp.DomainI ‹rel_set A X X' rel_setD1 subsetD)
  show 
    "(
        t u. 
          finite t  
          t  X  
          sum_with p z (λv. s (u v) v) t = z  
          (vt. u v  zb)
     ) =
      (
        t u. 
          finite t  
          t  X'  
          sum_with p' z' (λv. s' (u v) v) t = z'  
          (vt. u v  zb')
      )"
    apply transfer_prover_start
    apply transfer_step+
    by (insert *) (auto intro!: comm_monoid_add_ow.sum_with_closed)
qed

ctr relativization
  synthesis ctr_simps
  assumes [transfer_rule]: "is_equality A" "bi_unique B"
  trp (?'a A) and (?'b B) 
  in subspace_with: subspace.with_def



subsectionmodule_ow›


subsubsection‹Definitions and common properties›


text‹Single module.›

locale module_ow = ab_group_add_ow UM plusM zeroM minusM uminusM
  for UM :: "'m set" 
    and plusM (infixl +M 65)
    and zeroM (0M)
    and minusM (infixl -M 65)
    and uminusM (-M _› [81] 80) +
  fixes scale :: "['cr1::comm_ring_1, 'm]  'm" (infixr "*sM" 75)
  assumes scale_closed[simp, intro]: "x  UM  a *sM x  UM"
    and scale_right_distrib[algebra_simps]: 
    " x  UM; y  UM   a *sM (x +M y) = a *sM x +M a *sM y"
    and scale_left_distrib[algebra_simps]: 
      "x  UM  (a + b) *sM x = a *sM x +M b *sM x"
    and scale_scale[simp]: 
      "x  UM  a *sM (b *sM x) = (a * b) *sM x"
    and scale_one[simp]: "x  UM  1 *sM x = x"
begin

lemma scale_closed'[simp]: "a. xUM. a *sM x  UM" by simp

lemma minus_closed'[simp]: "xUM. yUM. x -M y  UM"
  by (simp add: ab_diff_conv_add_uminus add_closed' uminus_closed)

lemma uminus_closed'[simp]: "xUM. -M x  UM" by (simp add: uminus_closed)

tts_register_sbts (*sM) | UM
  by (rule tts_AB_C_transfer[OF scale_closed])
    (auto simp: bi_unique_eq right_total_eq)

tts_register_sbts plusM | UM
  by (rule tts_AB_C_transfer[OF add_closed])
    (auto simp: bi_unique_eq right_total_eq)

tts_register_sbts zeroM | UM 
  by (meson Domainp.cases zero_closed)

end


text‹Pair of modules.›

locale module_pair_ow = 
  M1: module_ow UM_1 plusM_1 zeroM_1 minusM_1 uminusM_1 scale1 +
  M2: module_ow UM_2 plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
  for UM_1 :: "'m_1 set"
    and plusM_1 (infixl +M'_1 65)
    and zeroM_1 (0M'_1)
    and minusM_1 (infixl -M'_1 65)
    and uminusM_1 (-M'_1 _› [81] 80)
    and scale1 :: "['cr1::comm_ring_1, 'm_1]  'm_1" (infixr *sM'_1 75)
    and UM_2 :: "'m_2 set"
    and plusM_2 (infixl +M'_2 65)
    and zeroM_2 (0M'_2)
    and minusM_2 (infixl -M'_2 65)
    and uminusM_2 (-M'_2 _› [81] 80)
    and scale2 :: "['cr1::comm_ring_1, 'm_2]  'm_2" (infixr *sM'_2 75)


text‹Module homomorphisms.›

locale module_hom_ow = 
  M1: module_ow UM_1 plusM_1 zeroM_1 minusM_1 uminusM_1 scale1 +
  M2: module_ow UM_2 plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
  for UM_1 :: "'m_1 set"
    and plusM_1 (infixl +M'_1 65)
    and zeroM_1 (0M'_1)
    and minusM_1 (infixl -M'_1 65)
    and uminusM_1 (-M'_1 _› [81] 80)
    and scale1 :: "['cr1::comm_ring_1, 'm_1]  'm_1" (infixr *sM'_1 75)
    and UM_2 :: "'m_2 set"
    and plusM_2 (infixl +M'_2 65)
    and zeroM_2 (0M'_2)
    and minusM_2 (infixl -M'_2 65)
    and uminusM_2 (-M'_2 _› [81] 80)
    and scale2 :: "['cr1::comm_ring_1, 'm_2]  'm_2" (infixr *sM'_2 75) +
  fixes f :: "'m_1  'm_2"
  assumes f_closed[simp]: "f ` UM_1  UM_2" 
    and add: " b1  UM_1; b2  UM_1   f (b1 +M_1 b2) = f b1 +M_2 f b2"
    and scale: " r  UCR1; b  UM_1   f (r *sM_1 b) = r *sM_2 f b"
begin

tts_register_sbts f | UM_1 and UM_2 by (rule tts_AB_transfer[OF f_closed])

lemma f_closed'[simp]: "xUM_1. f x  UM_2" using f_closed by blast

sublocale module_pair_ow ..

end


subsubsection‹Transfer.›

lemma module_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique B" "right_total B"     
  fixes PP lhs
  defines
    "PP  
      (
        (B ===> B ===> B) ===>
        B ===>
        (B ===> B ===> B) ===>
        (B ===> B) ===>
        ((=) ===> B ===> B) ===>
        (=)
      )"
    and
      "lhs  
        (
          λ plusM zeroM minusM uminusM scale.
          module_ow (Collect (Domainp B)) plusM zeroM minusM uminusM scale
        )"
  shows "PP lhs (module_with)"
proof-
  let ?rhs = 
    "(
      λplusM zeroM minusM uminusM scale.
        (a  UNIV. x  UNIV. scale a x  UNIV) 
         module_with plusM zeroM minusM uminusM scale
    )"
  have "PP lhs ?rhs"
    unfolding 
      PP_def lhs_def
      module_ow_def module_with_def
      module_ow_axioms_def module_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by (intro ext) blast
  then show ?thesis by simp
qed

lemma module_pair_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "bi_unique B1" "right_total B1" "bi_unique B2" "right_total B2"     
  fixes PP lhs
  defines
    "PP  
      (
        (B1 ===> B1 ===> B1) ===>
        B1 ===>
        (B1 ===> B1 ===> B1) ===>
        (B1 ===> B1) ===>
        ((=) ===> B1 ===> B1) ===>
        (B2 ===> B2 ===> B2) ===>
        B2 ===>
        (B2 ===> B2 ===> B2) ===>
        (B2 ===> B2) ===>
        ((=) ===> B2 ===> B2) ===>
        (=)
    )"
    and
      "lhs  
        (
          λ
            plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
            plusM_2 zeroM_2 minusM_2 uminusM_2 scale2.
          module_pair_ow 
            (Collect (Domainp B1)) plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
            (Collect (Domainp B2)) plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
        )"
    shows "PP lhs module_pair_with"
  unfolding PP_def lhs_def
proof(intro rel_funI) 
  let ?rhs = 
    "(
      λ
        plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
        plusM_2 zeroM_2 minusM_2 uminusM_2 scale2.
          (a  UNIV. x  UNIV. scale1 a x  UNIV) 
          (a  UNIV. x  UNIV. scale2 a x  UNIV) 
          module_pair_with 
            plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
            plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
    )"
  fix 
    plusM_1 plusM_1' 
    zeroM_1 zeroM_1' 
    minusM_1 minusM_1' 
    uminusM_1 uminusM_1' 
    plusM_2 plusM_2' 
    zeroM_2 zeroM_2' 
    minusM_2 minusM_2' 
    uminusM_2 uminusM_2' 
    and scale1 :: "'f::comm_ring_1  'a  'a" and scale1' 
    and scale2 :: "'f::comm_ring_1  'c  'c" and scale2'
  assume [transfer_rule]: 
    "(B1 ===> B1 ===> B1) plusM_1 plusM_1'"
    "B1 zeroM_1 zeroM_1'"
    "(B1 ===> B1 ===> B1) minusM_1 minusM_1'"
    "(B1 ===> B1) uminusM_1 uminusM_1'"
    "(B2 ===> B2 ===> B2) plusM_2 plusM_2'"
    "B2 zeroM_2 zeroM_2'"
    "(B2 ===> B2 ===> B2) minusM_2 minusM_2'"
    "(B2 ===> B2) uminusM_2 uminusM_2'"
    "((=) ===> B1 ===> B1) scale1 scale1'"
    "((=) ===> B2 ===> B2) scale2 scale2'"
  show 
    "module_pair_ow 
      (Collect (Domainp B1)) plusM_1 zeroM_1 minusM_1 uminusM_1 scale1 
      (Collect (Domainp B2)) plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
      =
    module_pair_with
      plusM_1' zeroM_1' minusM_1' uminusM_1' scale1'
      plusM_2' zeroM_2' minusM_2' uminusM_2' scale2'"
    unfolding module_pair_ow_def module_pair_with_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
qed

lemma module_hom_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "bi_unique B1" "right_total B1" "bi_unique B2" "right_total B2"     
  fixes PP lhs
  defines
    "PP  
      (
        (B1 ===> B1 ===> B1) ===>
        B1 ===>
        (B1 ===> B1 ===> B1) ===>
        (B1 ===> B1) ===>
        ((=) ===> B1 ===> B1) ===>
        (B2 ===> B2 ===> B2) ===>
        B2 ===>
        (B2 ===> B2 ===> B2) ===>
        (B2 ===> B2) ===>
        ((=) ===> B2 ===> B2) ===>
        (B1 ===> B2) ===>
        (=)
      )"
    and
      "lhs  
        (
          λ
            plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
            plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
            f.
          module_hom_ow 
            (Collect (Domainp B1)) plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
            (Collect (Domainp B2)) plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
            f
        )"
    shows "PP lhs module_hom_with"
proof-
  let ?rhs = 
    "(
      λ
        plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
        plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
        f. 
        (x  UNIV. f x  UNIV) 
        module_hom_with
          plusM_1 zeroM_1 minusM_1 uminusM_1 scale1
          plusM_2 zeroM_2 minusM_2 uminusM_2 scale2
          f
    )"
  have "PP lhs ?rhs"
    unfolding 
      PP_def lhs_def 
      module_hom_ow_def module_hom_with_def
      module_hom_ow_axioms_def module_hom_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by (intro ext) blast
  then show ?thesis by simp
qed



subsectionmodule_on›


subsubsection‹Definitions and common properties›

locale module_on =
  fixes UM
    and scale :: "'a::comm_ring_1  'b::ab_group_add  'b" (infixr "*s" 75)
  assumes scale_right_distrib_on[algebra_simps]: 
      " x  UM; y  UM   a *s (x + y) = a *s x + a *s y"
    and scale_left_distrib_on[algebra_simps]: 
      "x  UM  (a + b) *s x = a *s x + b *s x"
    and scale_scale_on[simp]: "x  UM  a *s (b *s x) = (a * b) *s x"
    and scale_one_on[simp]: "x  UM  1 *s x = x"
    and closed_add: " x  UM; y  UM   x + y  UM"
    and closed_zero: "0  UM"
    and closed_scale: "x  UM  a *s x  UM"
begin

lemma S_ne: "UM  {}" using closed_zero by auto

lemma scale_minus_left_on: 
  assumes "x  UM" 
  shows "scale (- a) x = - scale a x" 
  by 
    (
      metis 
        add_cancel_right_right scale_left_distrib_on neg_eq_iff_add_eq_0 assms
    )

lemma closed_uminus: 
  assumes "x  UM"
  shows "-x  UM"
  by (metis assms closed_scale scale_minus_left_on scale_one_on)

sublocale implicitM: ab_group_add_ow UM (+) 0 (-) uminus
  by unfold_locales (simp_all add: closed_add closed_zero closed_uminus)

sublocale implicitM: module_ow UM (+) 0 (-) uminus (*s)
  by unfold_locales 
    (simp_all add: closed_scale scale_right_distrib_on scale_left_distrib_on)

definition subspace :: "'b set  bool"
  where subspace_on_def: "subspace T  
    0  T  (xT. yT. x + y  T)  (c. xT. c *s x  T)"

definition span :: "'b set  'b set"
  where span_on_def: "span b = {sum (λa. r a *s  a) t | t r. finite t  t  b}"

definition dependent :: "'b set  bool"
  where dependent_on_def: "dependent s  
    (t u. finite t  t  s  (sum (λv. u v *s v) t = 0  (vt. u v  0)))"

lemma implicit_subspace_with[tts_implicit]: "subspace.with (+) 0 (*s) = subspace"
  unfolding subspace_on_def subspace.with_def ..

lemma implicit_dependent_with[tts_implicit]: 
  "dependent.with 0 0 (+) (*s) = dependent"
  unfolding dependent_on_def dependent.with_def sum_with ..

lemma implicit_span_with[tts_implicit]: "span.with 0 (+) (*s) = span"
  unfolding span_on_def span.with_def sum_with ..

end

lemma implicit_module_ow[tts_implicit]:
  "module_ow UM (+) 0 (-) uminus = module_on UM"
proof (intro ext iffI)
  fix s::"'a'b'b" assume "module_on UM s"
  then interpret module_on UM s .
  show "module_ow UM (+) 0 (-) uminus s" 
    by (simp add: implicitM.module_ow_axioms)
next
  fix s::"'a'b'b" assume "module_ow UM (+) 0 (-) uminus s"
  then interpret module_ow UM (+) 0 (-) uminus s .
  show "module_on UM s" 
    by (simp add: scale_left_distrib scale_right_distrib module_on.intro)
qed

locale module_pair_on = 
  M1: module_on UM_1 scale1 + M2: module_on UM_2 scale2
  for UM_1:: "'b::ab_group_add set" 
    and UM_2::"'c::ab_group_add set"
    and scale1::"'a::comm_ring_1  _  _" (infixr *s1 75)
    and scale2::"'a::comm_ring_1  _  _" (infixr *s2 75)
begin

sublocale implicitM: module_pair_ow 
  UM_1 (+) 0 (-) uminus scale1 UM_2 (+) 0 (-) uminus scale2
  by unfold_locales

end

lemma implicit_module_pair_ow[tts_implicit]:
  "module_pair_ow UM_1 (+) 0 (-) uminus scale1 UM_2 (+) 0 (-) uminus scale2 = 
    module_pair_on UM_1 UM_2 scale1 scale2"
  unfolding module_pair_ow_def implicit_module_ow module_pair_on_def ..

locale module_hom_on = M1: module_on UM_1 scale1 + M2: module_on UM_2 scale2
  for UM_1 :: "'b::ab_group_add set" and UM_2 :: "'c::ab_group_add set"
    and scale1 :: "'a::comm_ring_1  'b  'b" (infixr *s1 75)
    and scale2 :: "'a::comm_ring_1  'c  'c" (infixr *s2 75) +
  fixes f :: "'b  'c"
  assumes hom_closed: "f ` UM_1  UM_2"
    and add: "b1 b2.  b1  UM_1; b2  UM_1   f (b1 + b2) = f b1 + f b2"
    and scale: "b. b  UM_1  f (r *s1 b) = r *s2 f b"
begin

sublocale module_pair_on UM_1 UM_2 scale1 scale2 by unfold_locales

sublocale implicitM: module_hom_ow 
  UM_1 (+) 0 (-) uminus scale1 UM_2 (+) 0 (-) uminus scale2
  by unfold_locales (simp_all add: hom_closed add scale)
 
end

lemma implicit_module_hom_ow[tts_implicit]:
  "module_hom_ow UM_1 (+) 0 (-) uminus scale1 UM_2 (+) 0 (-) uminus scale2 = 
    module_hom_on UM_1 UM_2 scale1 scale2"
  unfolding 
    module_hom_ow_def 
    module_hom_on_def 
    module_hom_ow_axioms_def
    module_hom_on_axioms_def
    tts_implicit
  by (intro ext) auto



subsection‹Relativization.›

context module_on
begin

tts_context
  tts: (?'b to UM::'b set›)
  rewriting ctr_simps
  substituting implicitM.module_ow_axioms
    and implicitM.ab_group_add_ow_axioms
  eliminating ?a  UM and ?B  UM through auto
  applying 
    [
      OF 
        implicitM.carrier_ne 
        implicitM.add_closed' 
        implicitM.minus_closed' 
        implicitM.uminus_closed' 
        implicitM.scale_closed',
      unfolded tts_implicit
    ]
begin

tts_lemma scale_left_commute:
  assumes "x  UM"
  shows "a *s b *s x = b *s a *s x"
    is module.scale_left_commute.

tts_lemma scale_zero_left:
  assumes "x  UM"
  shows "0 *s x = 0"
    is module.scale_zero_left.
    
tts_lemma scale_minus_left:
  assumes "x  UM"
  shows "- a *s x = - (a *s x)"
    is module.scale_minus_left.

tts_lemma scale_left_diff_distrib:
  assumes "x  UM"
  shows "(a - b) *s x = a *s x - b *s x"
    is module.scale_left_diff_distrib.

tts_lemma scale_sum_left:
  assumes "x  UM"
  shows "sum f A *s x = (aA. f a *s x)"
    is module.scale_sum_left.

tts_lemma scale_zero_right: "a *s 0 = 0"
    is module.scale_zero_right.
    
tts_lemma scale_minus_right:
  assumes "x  UM"
  shows "a *s - x = - (a *s x)"
    is module.scale_minus_right.
    
tts_lemma scale_right_diff_distrib:
  assumes "x  UM" and "y  UM"
  shows "a *s (x - y) = a *s x - a *s y"
    is module.scale_right_diff_distrib.

tts_lemma scale_sum_right:
  assumes "range f  UM"
  shows "a *s sum f A = (xA. a *s f x)"
    is module.scale_sum_right.

tts_lemma sum_constant_scale:
  assumes "y  UM"
  shows "(xA. y) = of_nat (card A) *s y"
    is module.sum_constant_scale.

tts_lemma subspace_def:
  assumes "S  UM"
  shows "subspace S =
    (0  S  (x. yS. x *s y  S)  (xS. yS. x + y  S))"
    is module.subspace_def.

tts_lemma subspaceI:
  assumes "S  UM"
    and "0  S"
    and "x y. x  UM; y  UM; x  S; y  S  x + y  S"
    and "c x. x  UM; x  S  c *s x  S"
  shows "subspace S"
    is module.subspaceI.

tts_lemma subspace_single_0: "subspace {0}"
    is module.subspace_single_0.

tts_lemma subspace_0:
  assumes "S  UM" and "subspace S"
  shows "0  S"
    is module.subspace_0.

tts_lemma subspace_add:
  assumes "S  UM" and "subspace S" and "x  S" and "y  S"
  shows "x + y  S"
    is module.subspace_add.

tts_lemma subspace_scale:
  assumes "S  UM" and "subspace S" and "x  S"
  shows "c *s x  S"
    is module.subspace_scale.

tts_lemma subspace_neg:
  assumes "S  UM" and "subspace S" and "x  S"
  shows "- x  S"
    is module.subspace_neg.

tts_lemma subspace_diff:
  assumes "S  UM" and "subspace S" and "x  S" and "y  S"
  shows "x - y  S"
    is module.subspace_diff.

tts_lemma subspace_sum:
  assumes "A  UM"
    and "range f  UM"
    and "subspace A"
    and "x. x  B  f x  A"
  shows "sum f B  A"
    is module.subspace_sum.

tts_lemma subspace_inter:
  assumes "A  UM" and "B  UM" and "subspace A" and "subspace B"
  shows "subspace (A  B)"
    is module.subspace_inter.

tts_lemma span_explicit':
  assumes "b  UM"
  shows "span b = 
    {
      x  UM. f. 
        x = (v{x  UM. f x  0}. f v *s v)  
        finite {x  UM. f x  0}  
        (xUM. f x  0  x  b)
    }"
   is module.span_explicit'.

tts_lemma span_finite:
  assumes "S  UM" and "finite S"
  shows "span S = range (λu. vS. u v *s v)"
    is module.span_finite.

tts_lemma span_induct_alt:
  assumes "x  UM"
    and "S  UM"
    and "x  span S"
    and "h 0"
    and "c x y. x  UM; y  UM; x  S; h y  h (c *s x + y)"
  shows "h x"
    is module.span_induct_alt.

tts_lemma span_mono:
  assumes "B  UM" and "A  B"
  shows "span A  span B"
    is module.span_mono.

tts_lemma span_base:
  assumes "S  UM" and "a  S"
  shows "a  span S"
    is module.span_base.

tts_lemma span_superset:
  assumes "S  UM"
  shows "S  span S"
    is module.span_superset.

tts_lemma span_zero:
  assumes "S  UM"
  shows "0  span S"
    is module.span_zero.

tts_lemma span_add:
  assumes "x  UM"
    and "S  UM"
    and "y  UM"
    and "x  span S"
    and "y  span S"
  shows "x + y  span S"
    is module.span_add.

tts_lemma span_scale:
  assumes "x  UM" and "S  UM" and "x  span S"
  shows "c *s x  span S"
    is module.span_scale.

tts_lemma subspace_span:
  assumes "S  UM"
  shows "subspace (span S)"
    is module.subspace_span.

tts_lemma span_neg:
  assumes "x  UM" and "S  UM" and "x  span S"
  shows "- x  span S"
    is module.span_neg.

tts_lemma span_diff:
  assumes "x  UM"
    and "S  UM"
    and "y  UM"
    and "x  span S"
    and "y  span S"
  shows "x - y  span S"
    is module.span_diff.

tts_lemma span_sum:
  assumes "range f  UM" and "S  UM" and "x. x  A  f x  span S"
  shows "sum f A  span S"
    is module.span_sum.

tts_lemma span_minimal:
  assumes "T  UM" and "S  T" and "subspace T"
  shows "span S  T"
    is module.span_minimal.

tts_lemma span_subspace_induct:
  assumes "x  UM"
    and "S  UM"
    and "P  UM"
    and "x  span S"
    and "subspace P"
    and "x. x  S  x  P"
  shows "x  P"
    given module.span_subspace_induct 
    by simp

tts_lemma span_induct:
  assumes "x  UM"
    and "S  UM"
    and "x  span S"
    and "subspace {x. P x  x  UM}"
    and "x. x  S  P x"
  shows "P x"
    given module.span_induct by blast

tts_lemma span_empty: "span {} = {0}"
    is module.span_empty.

tts_lemma span_subspace:
  assumes "B  UM" and "A  B" and "B  span A" and "subspace B"
  shows "span A = B"
    is module.span_subspace.

tts_lemma span_span:
  assumes "A  UM"
  shows "span (span A) = span A"
    is module.span_span.

tts_lemma span_add_eq:
  assumes "x  UM" and "S  UM" and "y  UM" and "x  span S"
  shows "(x + y  span S) = (y  span S)"
    is module.span_add_eq.

tts_lemma span_add_eq2:
  assumes "y  UM" and "S  UM" and "x  UM" and "y  span S"
  shows "(x + y  span S) = (x  span S)"
    is module.span_add_eq2.

tts_lemma span_singleton:
  assumes "x  UM"
  shows "span {x} = range (λk. k *s x)"
    is module.span_singleton.

tts_lemma span_Un:
  assumes "S  UM" and "T  UM"
  shows "span (S  T) = 
    {x  UM. aUM. bUM. x = a + b  a  span S  b  span T}"
    is module.span_Un.

tts_lemma span_insert:
  assumes "a  UM" and "S  UM"
  shows "span (insert a S) = {x  UM. y. x - y *s a  span S}"
    is module.span_insert.

tts_lemma span_breakdown:
  assumes "S  UM" and "a  UM" and "b  S" and "a  span S"
  shows "x. a - x *s b  span (S - {b})"
    is module.span_breakdown.

tts_lemma span_breakdown_eq:
  assumes "x  UM" and "a  UM" and "S  UM"
  shows "(x  span (insert a S)) = (y. x - y *s a  span S)"
    is module.span_breakdown_eq.

tts_lemma span_clauses:
  "S  UM; a  S  a  span S"
  "S  UM  0  span S"
  "x  UM; S  UM; y  UM; x  span S; y  span S  x + y  span S"
  "x  UM; S  UM; x  span S  c *s x  span S"
  is module.span_clauses.

tts_lemma span_eq_iff:
  assumes "s  UM"
  shows "(span s = s) = subspace s"
    is module.span_eq_iff.

tts_lemma span_eq:
  assumes "S  UM" and "T  UM"
  shows "(span S = span T) = (S  span T  T  span S)"
    is module.span_eq.

tts_lemma eq_span_insert_eq:
  assumes "x  UM" and "y  UM" and "S  UM" and "x - y  span S"
  shows "span (insert x S) = span (insert y S)"
    is module.eq_span_insert_eq.

tts_lemma dependent_mono:
  assumes "A  UM" and "dependent B" and "B  A"
  shows "dependent A"
    is module.dependent_mono.

tts_lemma independent_mono:
  assumes "A  UM" and "¬ dependent A" and "B  A"
  shows "¬ dependent B"
    is module.independent_mono.

tts_lemma dependent_zero:
  assumes "A  UM" and "0  A"
  shows "dependent A"
    is module.dependent_zero.

tts_lemma independent_empty: "¬ dependent {}"
    is module.independent_empty.

tts_lemma independentD:
  assumes "s  UM"
    and "¬ dependent s"
    and "finite t"
    and "t  s"
    and "(vt. u v *s v) = 0"
    and "v  t"
  shows "u v = 0"
    is module.independentD.

tts_lemma independent_Union_directed:
  assumes "C  Pow UM"
    and "c d. c  UM; d  UM; c  C; d  C  c  d  d  c"
    and "c. c  UM; c  C  ¬ dependent c"
  shows "¬ dependent ( C)"
    is module.independent_Union_directed.

tts_lemma dependent_finite:
  assumes "S  UM" and "finite S"
  shows "dependent S = (x. (yS. x y  0)  (vS. x v *s v) = 0)"
    is module.dependent_finite.

tts_lemma independentD_alt:
  assumes "B  UM"
    and "x  UM"
    and "¬ dependent B"
    and "finite {x  UM. X x  0}"
    and "{x  UM. X x  0}  B"
    and "(x | x  UM  X x  0. X x *s x) = 0"
  shows "X x = 0"
    is module.independentD_alt.

tts_lemma spanning_subset_independent:
  assumes "A  UM" and "B  A" and "¬ dependent A" and "A  span B"
  shows "A = B"
    is module.spanning_subset_independent.

tts_lemma unique_representation:
  assumes "basis  UM"
    and "¬ dependent basis"
    and "v. v  UM; f v  0  v  basis"
    and "v. v  UM; g v  0  v  basis"
    and "finite {x  UM. f x  0}"
    and "finite {x  UM. g x  0}"
    and 
      "(v{x  UM. f x  0}. f v *s v) = (v{x  UM. g x  0}. g v *s v)"
  shows "xUM. f x = g x"
    is module.unique_representation[unfolded fun_eq_iff].

tts_lemma independentD_unique:
  assumes "B  UM"
    and "¬ dependent B"
    and "finite {x  UM. X x  0}"
    and "{x  UM. X x  0}  B"
    and "finite {x  UM. Y x  0}"
    and "{x  UM. Y x  0}  B"
    and "(x | x  UM  X x  0. X x *s x) = 
      (x | x  UM  Y x  0. Y x *s x)"
  shows "xUM. X x = Y x"
    is module.independentD_unique[unfolded fun_eq_iff].

tts_lemma subspace_UNIV: "subspace UM"
  is module.subspace_UNIV.

tts_lemma span_UNIV: "span UM = UM"
  is module.span_UNIV.

tts_lemma span_alt:
  assumes "B  UM"
  shows 
    "span B = 
      {
        x  UM. f. 
          x = (x | x  UM  f x  0. f x *s x)  
          finite {x  UM. f x  0}  
          {x  UM. f x  0}  B
      }"
    is module.span_alt.

tts_lemma dependent_alt:
  assumes "B  UM"
  shows "dependent B = 
    (
      f. 
        finite {v  UM. f v  0}  
        {v  UM. f v  0}  B  
        (vUM. f v  0)  
        (x | x  UM  f x  0. f x *s x) = 0
    )"
    is module.dependent_alt.

tts_lemma independent_alt:
  assumes "B  UM"
  shows 
    "(¬ dependent B) = 
      (
        f. 
          finite {x  UM. f x  0}  
          {x  UM. f x  0}  B  
          (x | x  UM  f x  0. f x *s x) = 0  
          (xUM. f x = 0)
    )"
    is module.independent_alt.

tts_lemma subspace_Int:
  assumes "range s  Pow UM" and "i. i  I  subspace (s i)"
  shows "subspace ( (s ` I)  UM)"
    is module.subspace_Int.

tts_lemma subspace_Inter:
  assumes "f  Pow UM" and "Ball f subspace"
  shows "subspace ( f  UM)"
    is module.subspace_Inter.

tts_lemma module_hom_scale_self: "module_hom_on UM UM (*s) (*s) ((*s) c)"
  is module.module_hom_scale_self.

tts_lemma module_hom_scale_left:
  assumes "x  UM"
  shows "module_hom_on UNIV UM (*) (*s) (λr. r *s x)"
  is module.module_hom_scale_left.

tts_lemma module_hom_id: "module_hom_on UM UM (*s) (*s) id"
  is module.module_hom_id.

tts_lemma module_hom_ident: "module_hom_on UM UM (*s) (*s) (λx. x)"
  is module.module_hom_ident.

tts_lemma module_hom_uminus: "module_hom_on UM UM (*s) (*s) uminus"
  is module.module_hom_uminus.

end

tts_context
  tts: (?'b to UM::'b set›)
  rewriting ctr_simps
  substituting implicitM.module_ow_axioms
    and implicitM.ab_group_add_ow_axioms
  eliminating ?a  UM and ?B  UM through clarsimp
  applying 
    [
      OF 
        implicitM.carrier_ne
        implicitM.add_closed' 
        implicitM.minus_closed' 
        implicitM.uminus_closed' 
        implicitM.scale_closed',
      unfolded tts_implicit
    ]
begin

tts_lemma span_explicit:
  assumes "b  UM"
  shows "span b = 
    {x  UM. yUM. f. (finite y  y  b)  x = (ay. f a *s a)}"
  given module.span_explicit by auto
    
tts_lemma span_unique:
  assumes "S  UM"
    and "T  UM"
    and "S  T"
    and "subspace T"
    and "T'. T'  UM; S  T'; subspace T'  T  T'"
  shows "span S = T"
    is module.span_unique.
    
tts_lemma dependent_explicit:
  assumes "V  UM"
  shows "dependent V = 
    (UUM. f. finite U  U  V  (vU. f v  0)  (vU. f v *s v) = 0)"
    given module.dependent_explicit by auto

tts_lemma independent_explicit_module:
  assumes "V  UM"
  shows "(¬ dependent V) = 
    (
      UUM. f. vUM. 
        finite U  
        U  V  
        (uU. f u *s u) = 0  
        v  U  
        f v = 0
    )"
    given module.independent_explicit_module by auto

end

end

context module_pair_on 
begin

tts_context
  tts: (?'b to UM_1::'b set›) and (?'c to UM_2::'c set›)
  rewriting ctr_simps
  substituting M1.implicitM.module_ow_axioms
    and M2.implicitM.module_ow_axioms
    and M1.implicitM.ab_group_add_ow_axioms
    and M2.implicitM.ab_group_add_ow_axioms
    and implicitM.module_pair_ow_axioms
  eliminating through auto
  applying [unfolded tts_implicit]
begin

tts_lemma module_hom_zero: "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. 0)"
    is module_pair.module_hom_zero.

tts_lemma module_hom_add:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "module_hom_on UM_1 UM_2 (*s1) (*s2) f"
    and "module_hom_on UM_1 UM_2 (*s1) (*s2) g"
  shows "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. f x + g x)"
    is module_pair.module_hom_add.
    
tts_lemma module_hom_sub:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "module_hom_on UM_1 UM_2 (*s1) (*s2) f"
    and "module_hom_on UM_1 UM_2 (*s1) (*s2) g"
  shows "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. f x - g x)"
    is module_pair.module_hom_sub.
    
tts_lemma module_hom_neg:
  assumes "xUM_1. f x  UM_2" and "module_hom_on UM_1 UM_2 (*s1) (*s2) f"
  shows "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. - f x)"
    is module_pair.module_hom_neg.
  
tts_lemma module_hom_scale:
  assumes "xUM_1. f x  UM_2" and "module_hom_on UM_1 UM_2 (*s1) (*s2) f"
  shows "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. c *s2 f x)"
    is module_pair.module_hom_scale.
    
tts_lemma module_hom_compose_scale:
  assumes "c  UM_2" and "module_hom_on UM_1 UNIV (*s1) (*) f"
  shows "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. f x *s2 c)"
    is module_pair.module_hom_compose_scale.
    
tts_lemma module_hom_sum:
  assumes "u. vUM_1. f u v  UM_2"
    and "i. i  I  module_hom_on UM_1 UM_2 (*s1) (*s2) (f i)"
    and "I = {}  module_on UM_1 (*s1)  module_on UM_2 (*s2)"
  shows "module_hom_on UM_1 UM_2 (*s1) (*s2) (λx. iI. f i x)"
  is module_pair.module_hom_sum.

tts_lemma module_hom_eq_on_span:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "B  UM_1"
    and "x  UM_1"
    and "module_hom_on UM_1 UM_2 (*s1) (*s2) f"
    and "module_hom_on UM_1 UM_2 (*s1) (*s2) g"
    and "x. x  UM_1; x  B  f x = g x"
    and "x  M1.span B"
  shows "f x = g x"
    is module_pair.module_hom_eq_on_span.

end

end

text‹\newpage›

end

Theory VS_Vector_Spaces

(* Title: Examples/Vector_Spaces/VS_Vector_Spaces.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Vector spaces›
theory VS_Vector_Spaces
  imports VS_Modules
begin



subsectionvector_space_with›

locale vector_space_with = ab_group_add plusVS zeroVS minusVS uminusVS
  for plusVS :: "['vs, 'vs]  'vs" (infixl +VS 65)
    and zeroVS (0VS)
    and minusVS (infixl -VS 65)
    and uminusVS (-VS _› [81] 80) +
  fixes scale :: "['f::field, 'vs]  'vs" (infixr "*swith" 75)
  assumes scale_right_distrib[algebra_simps]: 
    "a *swith (x +VS y) = a *swith x +VS a *swith y"
    and scale_left_distrib[algebra_simps]:
      "(a + b) *swith x = a *swith x +VS b *swith x"
    and scale_scale[simp]: "a *swith (b *swith x) = (a * b) *swith x"
    and scale_one[simp]: "1 *swith x = x"
begin

notation plusVS (infixl +VS 65)
  and zeroVS (0VS)
  and minusVS (infixl -VS 65)
  and uminusVS (-VS _› [81] 80)
  and scale (infixr "*swith" 75)
  
end

lemma vector_space_with_overloaded[ud_with]: 
  "vector_space = vector_space_with (+) 0 (-) uminus"
  unfolding vector_space_def vector_space_with_def vector_space_with_axioms_def
  by (simp add: field_axioms ab_group_add_axioms)

locale vector_space_pair_with =
  VS1: vector_space_with plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 +
  VS2: vector_space_with plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
  for plusVS_1 :: "['vs_1, 'vs_1]  'vs_1" (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1"  (infixr *swith'_1 75)
    and plusVS_2 :: "['vs_2, 'vs_2]  'vs_2" (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *swith'_2 75)

lemma vector_space_pair_with_overloaded[ud_with]: 
  "vector_space_pair = 
    (
      λscale1 scale2. 
        vector_space_pair_with (+) 0 (-) uminus scale1 (+) 0 (-) uminus scale2
    )"
  unfolding vector_space_pair_def vector_space_pair_with_def 
  unfolding vector_space_with_overloaded
  ..

locale linear_with =
  VS1: vector_space_with plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 +
  VS2: vector_space_with plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2 +
  module_hom_with 
    plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
    plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
    f 
  for plusVS_1 :: "['vs_1, 'vs_1]  'vs_1" (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1"  (infixr *swith'_1 75)
    and plusVS_2 :: "['vs_2, 'vs_2]  'vs_2" (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *swith'_2 75)
    and f :: "'vs_1  'vs_2"

lemma linear_with_overloaded[ud_with]: 
  "Vector_Spaces.linear = 
    (
      λscale1 scale2. 
        linear_with (+) 0 (-) uminus scale1 (+) 0 (-) uminus scale2
    )"
  unfolding 
    Vector_Spaces.linear_def linear_with_def 
    vector_space_with_overloaded module_hom_with_overloaded
  ..

locale finite_dimensional_vector_space_with = 
  vector_space_with plusVS zeroVS minusVS uminusVS scale
  for plusVS :: "['vs, 'vs]  'vs"
    and zeroVS 
    and minusVS 
    and uminusVS 
    and scale :: "['f::field, 'vs]  'vs" +
  fixes basis :: "'vs set"
  assumes finite_basis: "finite basis"
    and independent_basis: "independent_with 0 0VS (+VS) (*swith) basis"
    and span_basis: "span.with 0VS (+VS) (*swith) basis = UNIV"

lemma finite_dimensional_vector_space_with_overloaded[ud_with]: 
  "finite_dimensional_vector_space = 
    finite_dimensional_vector_space_with (+) 0 (-) uminus"
  unfolding
    finite_dimensional_vector_space_def
    finite_dimensional_vector_space_axioms_def
    finite_dimensional_vector_space_with_def
    finite_dimensional_vector_space_with_axioms_def
  by (intro ext)
    (
      auto simp: 
        vector_space_with_overloaded 
        dependent.with 
        module_iff_vector_space
        span.with 
    )

locale finite_dimensional_vector_space_pair_1_with = 
  VS1: finite_dimensional_vector_space_with 
    plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1 +
  VS2: vector_space_with 
    plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
  for plusVS_1 :: "['vs_1, 'vs_1]  'vs_1" (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1" (infixr *swith'_1 75)
    and basis1
    and plusVS_2 :: "['vs_2, 'vs_2]  'vs_2" (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *swith'_2 75)

lemma finite_dimensional_vector_space_pair_1_with_overloaded[ud_with]: 
  "finite_dimensional_vector_space_pair_1 = 
    (
      λscale1 basis1 scale2. 
        finite_dimensional_vector_space_pair_1_with 
          (+) 0 (-) uminus scale1 basis1 (+) 0 (-) uminus scale2
    )"
  unfolding
    finite_dimensional_vector_space_pair_1_def
    finite_dimensional_vector_space_pair_1_with_def    
    vector_space_with_overloaded
  by (simp add: finite_dimensional_vector_space_with_overloaded)

locale finite_dimensional_vector_space_pair_with = 
  VS1: finite_dimensional_vector_space_with 
    plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1 +
  VS2: finite_dimensional_vector_space_with 
    plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2 basis2
  for plusVS_1 :: "['vs_1, 'vs_1]  'vs_1" (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1" (infixr *swith'_1 75)
    and basis1
    and plusVS_2 :: "['vs_2, 'vs_2]  'vs_2" (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *swith'_2 75)
    and basis2

lemma finite_dimensional_vector_space_pair_with_overloaded[ud_with]: 
  "finite_dimensional_vector_space_pair = 
    (
      λscale1 basis1 scale2 basis2. 
        finite_dimensional_vector_space_pair_with 
          (+) 0 (-) uminus scale1 basis1 (+) 0 (-) uminus scale2 basis2
    )"
  unfolding
    finite_dimensional_vector_space_pair_def
    finite_dimensional_vector_space_pair_with_def
    finite_dimensional_vector_space_with_overloaded
  ..



subsectionvector_space_ow›


subsubsection‹Definitions and common properties›


text‹Single vector space.›

locale vector_space_ow = ab_group_add_ow UVS plusVS zeroVS minusVS uminusVS
  for UVS :: "'vs set" 
    and plusVS (infixl +VS 65)
    and zeroVS (0VS)
    and minusVS (infixl -VS 65)
    and uminusVS (-VS _› [81] 80) +
  fixes scale :: "['f::field, 'vs]  'vs" (infixr "*sow" 75)
  assumes scale_closed[simp, intro]: "x  UVS  a *sow x  UVS"
    and scale_right_distrib[algebra_simps]: 
    " x  UVS; y  UVS   a *sow (x +VS y) = a *sow x +VS a *sow y"
    and scale_left_distrib[algebra_simps]: 
      "x  UVS  (a + b) *sow x = a *sow x +VS b *sow x"
    and scale_scale[simp]: 
      "x  UVS  a *sow (b *sow x) = (a * b) *sow x"
    and scale_one[simp]: "x  UVS  1 *sow x = x"
begin

lemma scale_closed'[simp]: "a. xUVS. a *sow x  UVS" by simp

lemma minus_closed'[simp]: "xUVS. yUVS. x -VS y  UVS"
  by (simp add: ab_diff_conv_add_uminus add_closed' uminus_closed)

lemma uminus_closed'[simp]: "xUVS. -VS x  UVS" by (simp add: uminus_closed)

tts_register_sbts (*sow) | UVS
  by (rule tts_AB_C_transfer[OF scale_closed]) 
    (auto simp: bi_unique_eq right_total_eq)

sublocale implicitVS: module_ow UVS plusVS zeroVS minusVS uminusVS scale
  by unfold_locales (simp_all add: scale_right_distrib scale_left_distrib)

end

ud ‹vector_space.dim›
ud dim' ‹dim›


text‹Pair of vector spaces.›

locale vector_space_pair_ow = 
  VS1: vector_space_ow UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 +
  VS2: vector_space_ow UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
  for UVS_1 :: "'vs_1 set"
    and plusVS_1 (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1" (infixr *sow'_1 75)
    and UVS_2 :: "'vs_2 set"
    and plusVS_2 (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *sow'_2 75)
begin

sublocale implicitVS: module_pair_ow 
  UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
  UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
  by unfold_locales

end


text‹Linear map.›

locale linear_ow =
  VS1: vector_space_ow UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 +
  VS2: vector_space_ow UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2 +
  module_hom_ow 
    UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
    UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
    f 
  for UVS_1 :: "'vs_1 set"
    and plusVS_1 (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1" (infixr *sow'_1 75)
    and UVS_2 :: "'vs_2 set"
    and plusVS_2 (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *sow'_2 75)
    and f :: "'vs_1  'vs_2"
begin

sublocale implicitVS: vector_space_pair_ow
  UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
  UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
  by unfold_locales

end


text‹Single finite dimensional vector space.›

locale finite_dimensional_vector_space_ow = 
  vector_space_ow UVS plusVS zeroVS minusVS uminusVS scale
  for UVS :: "'vs set"
    and plusVS (infixl +VS 65)
    and zeroVS (0VS)
    and minusVS (infixl -VS 65)
    and uminusVS (-VS _› [81] 80) 
    and scale :: "['f::field, 'vs]  'vs" (infixr "*sow" 75) +
  fixes basis :: "'vs set"
  assumes basis_closed: "basis  UVS"
    and finite_basis: "finite basis"
    and independent_basis: "independent_with 0 zeroVS plusVS scale basis"
    and span_basis: "span.with zeroVS plusVS scale basis = UVS"


text‹Pair of finite dimensional vector spaces.›

locale finite_dimensional_vector_space_pair_1_ow =
  VS1: finite_dimensional_vector_space_ow
    UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1 +
  VS2: vector_space_ow 
    UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
  for UVS_1 :: "'vs_1 set"
    and plusVS_1 (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1" (infixr *sow'_1 75)
    and basis1
    and UVS_2 :: "'vs_2 set"
    and plusVS_2 (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *sow'_2 75)

locale finite_dimensional_vector_space_pair_ow = 
  VS1: finite_dimensional_vector_space_ow 
    UVS_1 plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1 + 
  VS2: finite_dimensional_vector_space_ow 
    UVS_2 plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2 basis2
  for UVS_1 :: "'vs_1 set"
    and plusVS_1 (infixl +VS'_1 65)
    and zeroVS_1 (0VS'_1)
    and minusVS_1 (infixl -VS'_1 65)
    and uminusVS_1 (-VS'_1 _› [81] 80)
    and scale1 :: "['f::field, 'vs_1]  'vs_1" (infixr *sow'_1 75)
    and basis1
    and UVS_2 :: "'vs_2 set"
    and plusVS_2 (infixl +VS'_2 65)
    and zeroVS_2 (0VS'_2)
    and minusVS_2 (infixl -VS'_2 65)
    and uminusVS_2 (-VS'_2 _› [81] 80)
    and scale2 :: "['f::field, 'vs_2]  'vs_2" (infixr *sow'_2 75)
    and basis2


subsubsection‹Transfer.›

lemma vector_space_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique B" "right_total B"     
  fixes PP lhs
  defines
    "PP  
      (
        (B ===> B ===> B) ===>
        B ===>
        (B ===> B ===> B) ===>
        (B ===> B) ===>
        ((=) ===> B ===> B) ===>
        (=)
      )"
    and
      "lhs  
        (
          λplusVS zeroVS minusVS uminusVS scale.
            vector_space_ow 
              (Collect (Domainp B)) plusVS zeroVS minusVS uminusVS scale
        )"
  shows "PP lhs vector_space_with"
proof-
  let ?rhs = 
    "(
      λplusVS zeroVS minusVS uminusVS scale.
        (a  UNIV. x  UNIV. scale a x  UNIV) 
         vector_space_with plusVS zeroVS minusVS uminusVS scale
    )"
  have "PP lhs ?rhs"
    unfolding 
      PP_def lhs_def
      vector_space_ow_def vector_space_with_def
      vector_space_ow_axioms_def vector_space_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by (intro ext) blast
  then show ?thesis by simp
qed

lemma vector_space_pair_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "bi_unique B1" "right_total B1" "bi_unique B2" "right_total B2"     
  fixes PP lhs
  defines
    "PP  
      (
        (B1 ===> B1 ===> B1) ===>
        B1 ===>
        (B1 ===> B1 ===> B1) ===>
        (B1 ===> B1) ===>
        ((=) ===> B1 ===> B1) ===>
        (B2 ===> B2 ===> B2) ===>
        B2 ===>
        (B2 ===> B2 ===> B2) ===>
        (B2 ===> B2) ===>
        ((=) ===> B2 ===> B2) ===>
        (=)
    )"
    and
      "lhs  
        (
          λ
            plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
            plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2.
          vector_space_pair_ow 
            (Collect (Domainp B1)) plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
            (Collect (Domainp B2)) plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
        )"
    shows "PP lhs vector_space_pair_with"
  unfolding PP_def lhs_def
  unfolding vector_space_pair_ow_def vector_space_pair_with_def
  by transfer_prover

lemma linear_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "bi_unique B1" "right_total B1" "bi_unique B2" "right_total B2"     
  fixes PP lhs
  defines
    "PP  
      (
        (B1 ===> B1 ===> B1) ===>
        B1 ===>
        (B1 ===> B1 ===> B1) ===>
        (B1 ===> B1) ===>
        ((=) ===> B1 ===> B1) ===>
        (B2 ===> B2 ===> B2) ===>
        B2 ===>
        (B2 ===> B2 ===> B2) ===>
        (B2 ===> B2) ===>
        ((=) ===> B2 ===> B2) ===>
        (B1 ===> B2) ===>
        (=)
    )"
    and
      "lhs  
        (
          λ
            plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
            plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
            f.
          linear_ow 
            (Collect (Domainp B1)) plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
            (Collect (Domainp B2)) plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
            f
        )
      "
    shows "PP lhs linear_with"
  unfolding PP_def lhs_def
  unfolding linear_ow_def linear_with_def
  by transfer_prover

lemma linear_with_transfer'[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique B" "right_total B"
  fixes PP lhs
  defines
    "PP  
      (
        (B ===> B ===> B) ===>
        B ===>
        (B ===> B ===> B) ===>
        (B ===> B) ===>
        ((=) ===> B ===> B) ===>
        (B ===> B ===> B) ===>
        B ===>
        (B ===> B ===> B) ===>
        (B ===> B) ===>
        ((=) ===> B ===> B) ===>
        (B ===> B) ===>
        (=)
    )"
    and
      "lhs  
        (
          λ
            plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
            plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
            f.
          linear_ow 
            (Collect (Domainp B)) plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1
            (Collect (Domainp B)) plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
            f
        )
      "
    shows "PP lhs linear_with"
  unfolding PP_def lhs_def
  using assms(1,2) by (rule linear_with_transfer[OF assms(1,2)])

lemma finite_dimensional_vector_space_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique B" "right_total B"     
  fixes PP lhs
  defines
    "PP  
      (
        (B ===> B ===> B) ===>
        B ===>
        (B ===> B ===> B) ===>
        (B ===> B) ===>
        ((=) ===> B ===> B) ===>
        rel_set B ===>
        (=)
      )"
    and
      "lhs  
        (
          λplusVS zeroVS minusVS uminusVS scale basis.
            finite_dimensional_vector_space_ow 
              (Collect (Domainp B)) plusVS zeroVS minusVS uminusVS scale basis
        )"
    shows "PP lhs finite_dimensional_vector_space_with"
proof-
  let ?rhs = 
    "(
      λplusVS zeroVS minusVS uminusVS scale basis.
        basis  UNIV 
        finite_dimensional_vector_space_with 
          plusVS zeroVS minusVS uminusVS scale basis
    )"
  have "PP lhs ?rhs"
    unfolding 
      PP_def lhs_def
      finite_dimensional_vector_space_ow_def 
      finite_dimensional_vector_space_with_def
      finite_dimensional_vector_space_ow_axioms_def
      finite_dimensional_vector_space_with_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  then show ?thesis by simp
qed

lemma finite_dimensional_vector_space_pair_1_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "bi_unique B1" "right_total B1" "bi_unique B2" "right_total B2"     
  fixes PP lhs
  defines
    "PP  
      (
        (B1 ===> B1 ===> B1) ===>
        B1 ===>
        (B1 ===> B1 ===> B1) ===>
        (B1 ===> B1) ===>
        ((=) ===> B1 ===> B1) ===>
        rel_set B1 ===>
        (B2 ===> B2 ===> B2) ===>
        B2 ===>
        (B2 ===> B2 ===> B2) ===>
        (B2 ===> B2) ===>
        ((=) ===> B2 ===> B2) ===>
        (=)
    )"
    and
      "lhs  
        (
          λ
            plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1
            plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2.
          finite_dimensional_vector_space_pair_1_ow 
            (Collect (Domainp B1)) 
              plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1
            (Collect (Domainp B2)) 
              plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2
        )"
    shows "PP lhs finite_dimensional_vector_space_pair_1_with"
  unfolding PP_def lhs_def
  unfolding 
    finite_dimensional_vector_space_pair_1_ow_def
    finite_dimensional_vector_space_pair_1_with_def
  by transfer_prover

lemma finite_dimensional_vector_space_pair_with_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: 
    "bi_unique B1" "right_total B1" "bi_unique B2" "right_total B2"     
  fixes PP lhs
  defines
    "PP  
      (
        (B1 ===> B1 ===> B1) ===>
        B1 ===>
        (B1 ===> B1 ===> B1) ===>
        (B1 ===> B1) ===>
        ((=) ===> B1 ===> B1) ===>
        rel_set B1 ===>
        (B2 ===> B2 ===> B2) ===>
        B2 ===>
        (B2 ===> B2 ===> B2) ===>
        (B2 ===> B2) ===>
        ((=) ===> B2 ===> B2) ===>
        rel_set B2 ===>
        (=)
      )"
    and
      "lhs  
        (
          λ
            plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1
            plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2 basis2.
          finite_dimensional_vector_space_pair_ow 
            (Collect (Domainp B1)) 
              plusVS_1 zeroVS_1 minusVS_1 uminusVS_1 scale1 basis1
            (Collect (Domainp B2)) 
              plusVS_2 zeroVS_2 minusVS_2 uminusVS_2 scale2 basis2
        )"
    shows "PP lhs finite_dimensional_vector_space_pair_with"
  unfolding PP_def lhs_def
  unfolding 
    finite_dimensional_vector_space_pair_ow_def
    finite_dimensional_vector_space_pair_with_def
  by transfer_prover



subsectionvector_space_on›

locale vector_space_on = module_on UVS scale
  for UVS and scale :: "'a::field  'b::ab_group_add  'b" (infixr "*s" 75)
begin

notation scale (infixr "*s" 75)

sublocale implicitVS: vector_space_ow UVS (+) 0 (-) uminus scale
  by unfold_locales 
    (simp_all add: scale_right_distrib_on scale_left_distrib_on)

lemmas ab_group_add_ow_axioms = implicitM.ab_group_add_ow_axioms
lemmas vector_space_ow_axioms = implicitVS.vector_space_ow_axioms

definition dim :: "'b set  nat"
  where "dim V = (if bUVS. ¬ dependent b  span b = span V
    then card (SOME b. b  UVS  ¬ dependent b  span b = span V)
    else 0)"

end

lemma vector_space_on_alt_def: "vector_space_on UVS = module_on UVS"
  unfolding vector_space_on_def module_on_def
  by auto

lemma implicit_vector_space_ow[tts_implicit]:
  "vector_space_ow UVS (+) 0 (-) uminus = vector_space_on UVS"
proof(intro ext, rule iffI)
  fix s :: "'a  'b  'b" 
  assume "vector_space_ow UVS (+) 0 (-) uminus s"
  then interpret vector_space_ow UVS (+) 0 (-) uminus s .
  show "vector_space_on UVS s"
    by 
      (
        simp add: 
          scale_left_distrib 
          scale_right_distrib
          module_on_def 
          vector_space_on_def
      )
qed (rule vector_space_on.vector_space_ow_axioms)

locale linear_on = 
  VS1: vector_space_on UM_1 scale1 +
  VS2: vector_space_on UM_2 scale2 +
  module_hom_on UM_1 UM_2 scale1 scale2 f
  for UM_1 UM_2 and scale1::"'a::field  'b  'b::ab_group_add"
    and scale2::"'a::field  'c  'c::ab_group_add"
    and f

lemma implicit_linear_on[tts_implicit]:
  "linear_ow UM_1 (+) 0 minus uminus scale1 UM_2 (+) 0 (-) uminus scale2 = 
    linear_on UM_1 UM_2 scale1 scale2"
  unfolding linear_ow_def linear_on_def tts_implicit ..

locale finite_dimensional_vector_space_on =
  vector_space_on UVS scale 
  for UVS :: "'b::ab_group_add set" 
    and scale :: "'a::field  'b  'b" +
  fixes basis :: "'b set"
  assumes finite_basis: "finite basis"
    and independent_basis: "¬ dependent basis"
    and span_basis: "span basis = UVS" 
    and basis_subset: "basis  UVS"
begin

sublocale implicitVS: 
  finite_dimensional_vector_space_ow UVS (+) 0 (-) uminus scale basis
  by unfold_locales 
    (
      simp_all add: 
        finite_basis 
        implicit_dependent_with 
        independent_basis  
        implicit_span_with
        span_basis
        basis_subset
    )

end

lemma implicit_finite_dimensional_vector_space_on[tts_implicit]:
  "finite_dimensional_vector_space_ow UVS (+) 0 minus uminus scale basis = 
    finite_dimensional_vector_space_on UVS scale basis"
  unfolding 
    finite_dimensional_vector_space_ow_def 
    finite_dimensional_vector_space_on_def  
    finite_dimensional_vector_space_ow_axioms_def
    finite_dimensional_vector_space_on_axioms_def  
    vector_space_on_alt_def
    tts_implicit
  by (metis module_on.implicit_dependent_with module_on.implicit_span_with)  

locale vector_space_pair_on = 
  VS1: vector_space_on UM_1 scale1 +
  VS2: vector_space_on UM_2 scale2
  for UM_1:: "'b::ab_group_add set" and UM_2::"'c::ab_group_add set"
    and scale1::"'a::field  _  _" (infixr *s1 75) 
    and scale2::"'a  _  _" (infixr *s2 75)
begin

notation scale1 (infixr *s1 75)
notation scale2 (infixr *s2 75)

sublocale module_pair_on UM_1 UM_2 scale1 scale2 by unfold_locales

sublocale implicitVS: 
  vector_space_pair_ow 
    UM_1 (+) 0 (-) uminus scale1 
    UM_2 (+) 0 (-) uminus scale2
  by unfold_locales

end

lemma implicit_vector_space_pair_on[tts_implicit]:
  "vector_space_pair_ow 
    UM_1 (+) 0 (-) uminus scale1 
    UM_2 (+) 0 (-) uminus scale2 = 
    vector_space_pair_on UM_1 UM_2 scale1 scale2"
  unfolding vector_space_pair_ow_def vector_space_pair_on_def tts_implicit ..

locale finite_dimensional_vector_space_pair_1_on =
  VS1: finite_dimensional_vector_space_on UM_1 scale1 basis1 +
  VS2: vector_space_on UM_2 scale2
  for UM_1 UM_2
    and scale1::"'a::field  'b::ab_group_add  'b"
    and scale2::"'a::field  'c::ab_group_add  'c"
    and basis1
begin

sublocale vector_space_pair_on UM_1 UM_2 scale1 scale2 by unfold_locales

sublocale implicitVS:
  finite_dimensional_vector_space_pair_1_ow 
    UM_1 (+) 0 (-) uminus scale1 basis1 UM_2 (+) 0 (-) uminus scale2
  by unfold_locales

end

lemma implicit_finite_dimensional_vector_space_pair_1_on[tts_implicit]:
  "finite_dimensional_vector_space_pair_1_ow 
    UM_1 (+) 0 minus uminus scale1 basis1 UM_2 (+) 0 (-) uminus scale2 = 
    finite_dimensional_vector_space_pair_1_on UM_1 UM_2 scale1 scale2 basis1"
  unfolding 
    finite_dimensional_vector_space_pair_1_ow_def 
    finite_dimensional_vector_space_pair_1_on_def 
    tts_implicit 
    ..

locale finite_dimensional_vector_space_pair_on =
  VS1: finite_dimensional_vector_space_on UM_1 scale1 basis1 +
  VS2: finite_dimensional_vector_space_on UM_2 scale2 basis2
  for UM_1 UM_2
    and scale1::"'a::field  'b::ab_group_add  'b"
    and scale2::"'a::field  'c::ab_group_add  'c"
    and basis1 basis2
begin

sublocale finite_dimensional_vector_space_pair_1_on UM_1 UM_2 scale1 scale2 
  by unfold_locales

sublocale implicitVS: 
  finite_dimensional_vector_space_pair_ow 
    UM_1 (+) 0 (-) uminus scale1 basis1 
    UM_2 (+) 0 (-) uminus scale2 basis2
  by unfold_locales

end

lemma implicit_finite_dimensional_vector_space_pair_on[tts_implicit]:
  "finite_dimensional_vector_space_pair_ow 
      UM_1 (+) 0 minus uminus scale1 basis1 
      UM_2 (+) 0 (-) uminus scale2 basis2 = 
    finite_dimensional_vector_space_pair_on 
      UM_1 UM_2 scale1 scale2 basis1 basis2"
  unfolding 
    finite_dimensional_vector_space_pair_ow_def 
    finite_dimensional_vector_space_pair_on_def 
    tts_implicit 
    ..



subsection‹Relativization : part I›

context vector_space_on
begin

tts_context
  tts: (?'b to UVS::'b set›)
  rewriting ctr_simps
  substituting ab_group_add_ow_axioms
    and vector_space_ow_axioms
    and implicitM.module_ow_axioms
  applying 
    [
      OF 
        implicitM.carrier_ne 
        implicitM.add_closed' 
        implicitM.zero_closed 
        implicitVS.minus_closed' 
        implicitVS.uminus_closed' 
        implicitVS.scale_closed',
      unfolded tts_implicit
    ]
begin

tts_lemma linear_id: "linear_on UVS UVS (*s) (*s) id"
  is vector_space.linear_id.

tts_lemma linear_ident: "linear_on UVS UVS (*s) (*s) (λx. x)"
  is vector_space.linear_ident.
    
tts_lemma linear_scale_self: "linear_on UVS UVS (*s) (*s) ((*s) c)"
  is vector_space.linear_scale_self.
    
tts_lemma linear_scale_left:
  assumes "x  UVS"
  shows "linear_on UNIV UVS (*) (*s) (λr. r *s x)"
    is vector_space.linear_scale_left.
    
tts_lemma linear_uminus: "linear_on UVS UVS (*s) (*s) uminus"
    is vector_space.linear_uminus.
    
tts_lemma linear_imp_scale["consumes" - 1, "case_names" "1"]:
  assumes "range D  UVS"
    and "linear_on UNIV UVS (*) (*s) D"
    and "d. d  UVS; D = (λx. x *s d)  thesis"
  shows thesis
    is vector_space.linear_imp_scale.

tts_lemma scale_eq_0_iff:
  assumes "x  UVS"
  shows "(a *s x = 0) = (a = 0  x = 0)"
    is vector_space.scale_eq_0_iff.

tts_lemma scale_left_imp_eq:
  assumes "x  UVS" and "y  UVS" and "a  0" and "a *s x = a *s y"
  shows "x = y"
    is vector_space.scale_left_imp_eq.

tts_lemma scale_right_imp_eq:
  assumes "x  UVS" and "x  0" and "a *s x = b *s x"
  shows "a = b"
    is vector_space.scale_right_imp_eq.

tts_lemma scale_cancel_left:
  assumes "x  UVS" and "y  UVS"
  shows "(a *s x = a *s y) = (x = y  a = 0)"
    is vector_space.scale_cancel_left.

tts_lemma scale_cancel_right:
  assumes "x  UVS"
  shows "(a *s x = b *s x) = (a = b  x = 0)"
    is vector_space.scale_cancel_right.

tts_lemma injective_scale:
  assumes "c  0"
  shows "inj_on ((*s) c) UVS"
    is vector_space.injective_scale.

tts_lemma dependent_def:
  assumes "P  UVS"
  shows "dependent P = (xP. x  span (P - {x}))"
    is vector_space.dependent_def.

tts_lemma dependent_single:
  assumes "x  UVS"
  shows "dependent {x} = (x = 0)"
    is vector_space.dependent_single.

tts_lemma in_span_insert:
  assumes "a  UVS"
    and "b  UVS"
    and "S  UVS"
    and "a  span (insert b S)"
    and "a  span S"
  shows "b  span (insert a S)"
    is vector_space.in_span_insert.

tts_lemma dependent_insertD:
  assumes "a  UVS" and "S  UVS" and "a  span S" and "dependent (insert a S)"
  shows "dependent S"
    is vector_space.dependent_insertD.

tts_lemma independent_insertI:
  assumes "a  UVS" and "S  UVS" and "a  span S" and "¬ dependent S"
  shows "¬ dependent (insert a S)"
    is vector_space.independent_insertI.

tts_lemma independent_insert:
  assumes "a  UVS" and "S  UVS"
  shows "(¬ dependent (insert a S)) = 
    (if a  S then ¬ dependent S else ¬ dependent S  a  span S)"
    is vector_space.independent_insert.

tts_lemma maximal_independent_subset_extend["consumes" - 1, "case_names" "1"]:
  assumes "S  UVS"
    and "V  UVS"
    and "S  V"
    and "¬ dependent S"
    and "B. B  UVS; S  B; B  V; ¬ dependent B; V  span B  thesis"
  shows thesis
    is vector_space.maximal_independent_subset_extend.

tts_lemma maximal_independent_subset["consumes" - 1, "case_names" "1"]:
  assumes "V  UVS"
    and "B. B  UVS; B  V; ¬ dependent B; V  span B  thesis"
  shows thesis
    is vector_space.maximal_independent_subset.

tts_lemma in_span_delete:
  assumes "a  UVS"
    and "S  UVS"
    and "b  UVS"
    and "a  span S"
    and "a  span (S - {b})"
  shows "b  span (insert a (S - {b}))"
    is vector_space.in_span_delete.

tts_lemma span_redundant:
  assumes "x  UVS" and "S  UVS" and "x  span S"
  shows "span (insert x S) = span S"
    is vector_space.span_redundant.

tts_lemma span_trans:
  assumes "x  UVS"
    and "S  UVS"
    and "y  UVS"
    and "x  span S"
    and "y  span (insert x S)"
  shows "y  span S"
    is vector_space.span_trans.

tts_lemma span_insert_0:
  assumes "S  UVS"
  shows "span (insert 0 S) = span S"
    is vector_space.span_insert_0.

tts_lemma span_delete_0:
  assumes "S  UVS"
  shows "span (S - {0}) = span S"
    is vector_space.span_delete_0.

tts_lemma span_image_scale:
  assumes "S  UVS" and "finite S" and "x. x  UVS; x  S  c x  0"
  shows "span ((λx. c x *s x) ` S) = span S"
    is vector_space.span_image_scale.

tts_lemma exchange_lemma:
  assumes "T  UVS"
    and "S  UVS"
    and "finite T"
    and "¬dependent S"
    and "S  span T"
  shows "t'Pow UVS. 
    card t' = card T  finite t'  S  t'  t'  S  T  S  span t'"
    is vector_space.exchange_lemma.

tts_lemma independent_span_bound:
  assumes "T  UVS"
    and "S  UVS"
    and "finite T"
    and "¬ dependent S"
    and "S  span T"
  shows "finite S  card S  card T"
    is vector_space.independent_span_bound.

tts_lemma independent_explicit_finite_subsets:
  assumes "A  UVS"
  shows "(¬ dependent A) = 
    (
      xUVS. 
        x  A  
        finite x  
        (f. (vx. f v *s v) = 0  (xx. f x = 0))
    )"
    given vector_space.independent_explicit_finite_subsets by auto

tts_lemma independent_if_scalars_zero:
  assumes "A  UVS"
    and "finite A"
    and "f x. x  UVS; (xA. f x *s x) = 0; x  A  f x = 0"
  shows "¬ dependent A"
    is vector_space.independent_if_scalars_zero.

tts_lemma subspace_sums:
  assumes "S  UVS" and "T  UVS" and "subspace S" and "subspace T"
  shows "subspace {x  UVS. aUVS. bUVS. x = a + b  a  S  b  T}"
    is vector_space.subspace_sums.

tts_lemma bij_if_span_eq_span_bases:
  assumes "B  UVS"
    and "C  UVS"
    and "¬dependent B"
    and "¬dependent C"
    and "span B = span C"
  shows "x. bij_betw x B C  (aUVS. x a  UVS)"
    given vector_space.bij_if_span_eq_span_bases by blast

end

end



subsection‹Transfer: dim›

context vector_space_on
begin

lemma dim_eq_card:
  assumes "B  UVS"
    and "V  UVS"
    and BV: "span B = span V" 
    and B: "¬dependent B"
  shows "dim V = card B"
proof-
  define p where "p b  b  UVS  ¬dependent b  span b = span V" for b
  from assms have "p (SOME B. p B)"
    by (intro someI[of p B], unfold p_def) simp
  then have "f. bij_betw f B (SOME B. p B)  (xUVS. f x  UVS)"
    by (subst (asm) p_def, intro bij_if_span_eq_span_bases) (simp_all add: assms)
  then have "card B = card (SOME B. p B)" by (auto intro: bij_betw_same_card)
  then show ?thesis using assms(1,3,4) unfolding dim_def p_def by auto
qed

lemma dim_transfer[transfer_rule]: 
  includes lifting_syntax                               
  assumes [transfer_domain_rule]: "Domainp A = (λx. x  UVS)"
    and [transfer_rule]: "right_total A" "bi_unique A"
    and [transfer_rule]: "(A ===> A ===> A) plus plus'"
    and [transfer_rule]: "((=) ===> A ===> A) scale scale'"
    and [transfer_rule]: "A 0 zero'"
  shows "(rel_set A ===> (=)) dim (dim.with plus' zero' 0 scale')"
proof(rule rel_funI)
  
  (* preliminaries *)
  have rt_rlA: "right_total (rel_set A)"
    using assms using right_total_rel_set by auto
  have Dom_rsA: "Domainp (rel_set A) x = (x  UVS)" for x
    by (meson Domainp_set assms(1) in_mono subsetI)

  (* hypothesis and preliminary derived results *)
  fix V V' assume [transfer_rule]: "rel_set A V V'"
  with assms have subset: "V  UVS" 
    by (metis Domainp.DomainI rel_setD1 subsetI)
  then have "span V  UVS" by (simp add: span_minimal subspace_UNIV)

  (* convenience definitions *)
  define P' where "P' =
    (
      b. 
        (with 0 zero' plus' scale' : «independent» b)  
        (with zero' plus' scale' : «span» b) = 
          (with zero' plus' scale' : «span» V')
    )"
  define P where "P = 
    (bUVS. ¬ dependent b  span b = span V)"
  have "P = P'" 
    unfolding P_def P'_def by (transfer, unfold tts_implicit) blast
  define f where "f b = (b  UVS  ¬ dependent b  span b = span V)" for b
  define f' where "f' b = (b  UVS  f b)" for b
  have "f = f'" unfolding f'_def f_def by simp
  define g where "g b = 
    (
      (with 0 zero' plus' scale' : «independent» b)  
      (with zero' plus' scale': «span» b) = 
      (with zero' plus' scale' : «span» V')
    )"
    for b
  define g' where "g' b = (b  UNIV  g b)" for b
  have "g = g'" unfolding g_def g'_def by simp

  (* towards Eps_unique_transfer_lemma *)
  have fg[transfer_rule]: "(rel_set A ===> (=)) f g"
    unfolding g = g' 
    unfolding f_def g'_def g_def tts_implicit[symmetric]
    apply transfer_prover_start
    apply transfer_step+
    by simp
  have ex_Dom_rsA: "x. Domainp (rel_set A) x  f x"
    unfolding Dom_rsA f_def 
    by 
      (
        meson   
          ‹span V  UVS 
          maximal_independent_subset 
          span_subspace 
          subspace_span 
          subset
      )
  have card_xy: "x y. g x; g y  card x = card y"
    by (transfer, unfold f_def) (metis dim_eq_card)

  (* main *)
  show "dim V = dim.with plus' zero' 0 scale' V'"
  proof(cases P')
    case True
    then have P unfolding P = P' .
    then have dim: "dim V = card (SOME b. f b)"
      unfolding dim_def P_def f_def by simp
    from True have dw: "dim.with plus' zero' 0 scale' V' = card (SOME b. g b)"
      unfolding dim.with_def P'_def g_def by simp
    from Eps_unique_transfer_lemma[
        OF rt_rlA fg card_transfer[OF ‹bi_unique A] ex_Dom_rsA card_xy, 
        simplified,
        unfolded Dom_rsA,
        folded f'_def f = f'
        ]
    show "dim V = dim.with plus' zero' 0 scale' V'" 
      unfolding dim dw by simp
  next
    case False
    then have "¬P" unfolding P = P' .
    then have dim: "dim V = 0" unfolding dim_def P_def by auto 
    moreover from False have dw: "dim.with plus' zero'  0 scale' V' = 0"
      unfolding dim.with_def P'_def g_def by auto
    ultimately show ?thesis by simp
  qed

qed

end



subsection‹Relativization: part II›

context vector_space_on
begin

tts_context
  tts: (?'b to UVS::'b set›)
  sbterms: ((+)::?'b::ab_group_add?'b?'b to (+)::'b'b'b)
    and 
      (
        ?scale::?'a::field ?'b::ab_group_add?'b::ab_group_add› to 
        (*s)::'a'b'b
      )
    and (0::?'b::ab_group_add› to 0::'b)
  rewriting ctr_simps
  substituting ab_group_add_ow_axioms 
    and vector_space_ow_axioms
    and implicitM.module_ow_axioms
  eliminating ?a  ?A and ?B  ?C through auto
  applying 
    [
      OF 
        implicitM.carrier_ne 
        implicitVS.minus_closed' 
        implicitVS.uminus_closed', 
      unfolded tts_implicit
     ]
begin

tts_lemma dim_unique:
  assumes "V  UVS"
    and "B  V"
    and "V  span B"
    and "¬ dependent B"
    and "card B = n"
  shows "dim V = n"
    is vector_space.dim_unique.
    
tts_lemma basis_card_eq_dim:
  assumes "V  UVS" and "B  V" and "V  span B" and "¬ dependent B"
  shows "card B = dim V"
    is vector_space.basis_card_eq_dim.
    
tts_lemma dim_eq_card_independent:
  assumes "B  UVS" and "¬ dependent B"
  shows "dim B = card B"
    is vector_space.dim_eq_card_independent.

tts_lemma dim_span:
  assumes "S  UVS"
  shows "dim (span S) = dim S"
    is vector_space.dim_span.

tts_lemma dim_span_eq_card_independent:
  assumes "B  UVS" and "¬ dependent B"
  shows "dim (span B) = card B"
    is vector_space.dim_span_eq_card_independent.

tts_lemma dim_le_card:
  assumes "V  UVS" and "W  UVS" and "V  span W" and "finite W"
  shows "dim V  card W"
    is vector_space.dim_le_card.

tts_lemma span_eq_dim:
  assumes "S  UVS" and "T  UVS" and "span S = span T"
  shows "dim S = dim T"
    is vector_space.span_eq_dim.

tts_lemma dim_le_card':
  assumes "s  UVS" and "finite s"
  shows "dim s  card s"
    is vector_space.dim_le_card'.

tts_lemma span_card_ge_dim:
  assumes "V  UVS" and "B  V" and "V  span B" and "finite B"
  shows "dim V  card B"
    is vector_space.span_card_ge_dim.

end

tts_context
  tts: (?'b to UVS::'b set›) 
  sbterms: ((+)::?'b::ab_group_add?'b?'b to (+)::'b'b'b)
    and (?scale::?'a::field ?'b::ab_group_add?'b to (*s)::'a'b'b)
    and (0::?'b::ab_group_add› to 0::'b)
  rewriting ctr_simps
  substituting ab_group_add_ow_axioms 
    and vector_space_ow_axioms
    and implicitM.module_ow_axioms
  applying 
    [
      OF 
        implicitM.carrier_ne 
        implicitVS.minus_closed' 
        implicitVS.uminus_closed', 
        unfolded tts_implicit
     ]
begin
  
tts_lemma basis_exists:
  assumes "V  UVS"
    and "B. 
      
        B  UVS; 
        B  V; 
        ¬ dependent B; 
        V  span B; 
        card B = dim V
        thesis"
  shows thesis
    is vector_space.basis_exists.

end

end

context finite_dimensional_vector_space_on 
begin

tts_context
  tts: (?'b to UVS::'b set›)
  sbterms: ((+)::?'b::ab_group_add?'b?'b to (+)::'b'b'b)
    and (?scale::?'a::field ?'b::ab_group_add?'b to (*s)::'a'b'b)
    and (0::?'b::ab_group_add› to 0::'b)
  rewriting ctr_simps
  substituting ab_group_add_ow_axioms
    and vector_space_ow_axioms
    and implicitVS.finite_dimensional_vector_space_ow_axioms
    and implicitM.module_ow_axioms
  eliminating ?a  ?A and ?B  ?C through auto
  applying 
    [
      OF 
        implicitM.carrier_ne 
        implicitVS.minus_closed' 
        implicitVS.uminus_closed' 
        basis_subset, 
      unfolded tts_implicit
    ]
begin

tts_lemma finiteI_independent:
  assumes "B  UVS" and "¬ dependent B"
  shows "finite B"
  is finite_dimensional_vector_space.finiteI_independent.

tts_lemma dim_empty: "dim {} = 0"
  is finite_dimensional_vector_space.dim_empty.
    
tts_lemma dim_insert:
  assumes "x  UVS" and "S  UVS"
  shows "dim (insert x S) = (if x  span S then dim S else dim S + 1)"
    is finite_dimensional_vector_space.dim_insert.
    
tts_lemma dim_singleton:
  assumes "x  UVS"
  shows "dim {x} = (if x = 0 then 0 else 1)"
    is finite_dimensional_vector_space.dim_singleton.

tts_lemma choose_subspace_of_subspace["consumes" - 1, "case_names" "1"]:
  assumes "S  UVS"
    and "n  dim S"
    and "T. T  UVS; subspace T; T  span S; dim T = n  thesis"
  shows thesis
    is finite_dimensional_vector_space.choose_subspace_of_subspace.

tts_lemma basis_subspace_exists["consumes" - 1, "case_names" "1"]:
  assumes "S  UVS"
    and "subspace S"
    and "B. 
      
        B  UVS; 
        finite B; 
        B  S; 
        ¬ dependent B; 
        span B = S; 
        card B = dim S
        thesis"
  shows thesis
    is finite_dimensional_vector_space.basis_subspace_exists.

tts_lemma dim_mono:
  assumes "V  UVS" and "W  UVS" and "V  span W"
  shows "dim V  dim W"
    is finite_dimensional_vector_space.dim_mono.

tts_lemma dim_subset:
  assumes "T  UVS" and "S  T"
  shows "dim S  dim T"
    is finite_dimensional_vector_space.dim_subset.

tts_lemma dim_eq_0:
  assumes "S  UVS"
  shows "(dim S = 0) = (S  {0})"
    is finite_dimensional_vector_space.dim_eq_0.

tts_lemma dim_UNIV: "dim UVS = card basis"
    is finite_dimensional_vector_space.dim_UNIV.

tts_lemma independent_card_le_dim:
  assumes "V  UVS" and "B  V" and "¬ dependent B"
  shows "card B  dim V"
    is finite_dimensional_vector_space.independent_card_le_dim.

tts_lemma card_ge_dim_independent:
  assumes "V  UVS" and "B  V" and "¬ dependent B" and "dim V  card B"
  shows "V  span B"
    is finite_dimensional_vector_space.card_ge_dim_independent.

tts_lemma card_le_dim_spanning:
  assumes "V  UVS"
    and "B  V"
    and "V  span B"
    and "finite B"
    and "card B  dim V"
  shows "¬ dependent B"
    is finite_dimensional_vector_space.card_le_dim_spanning.

tts_lemma card_eq_dim:
  assumes "V  UVS" and "B  V" and "card B = dim V" and "finite B"
  shows "(¬ dependent B) = (V  span B)"
    is finite_dimensional_vector_space.card_eq_dim.

tts_lemma subspace_dim_equal:
  assumes "T  UVS"
    and "subspace S"
    and "subspace T"
    and "S  T"
    and "dim T  dim S"
  shows "S = T"
    is finite_dimensional_vector_space.subspace_dim_equal.

tts_lemma dim_eq_span:
  assumes "T  UVS" and "S  T" and "dim T  dim S"
  shows "span S = span T"
    is finite_dimensional_vector_space.dim_eq_span.

tts_lemma dim_psubset:
  assumes "S  UVS" and "T  UVS" and "span S  span T"
  shows "dim S < dim T"
    is finite_dimensional_vector_space.dim_psubset.

tts_lemma indep_card_eq_dim_span:
  assumes "B  UVS" and "¬ dependent B"
  shows "finite B  card B = dim (span B)"
    is finite_dimensional_vector_space.indep_card_eq_dim_span.

tts_lemma independent_bound_general:
  assumes "S  UVS" and "¬ dependent S"
  shows "finite S  card S  dim S"
    is finite_dimensional_vector_space.independent_bound_general.

tts_lemma independent_explicit:
  assumes "B  UVS"
  shows "(¬ dependent B) = 
    (finite B  (x. (vB. x v *s v) = 0  (aB. x a = 0)))"
    is finite_dimensional_vector_space.independent_explicit.

tts_lemma dim_sums_Int:
  assumes "S  UVS" and "T  UVS" and "subspace S" and "subspace T"
  shows 
    "dim {x  UVS. yUVS. zUVS. x = y + z  y  S  z  T} + dim (S  T) = 
      dim S + dim T"
    is finite_dimensional_vector_space.dim_sums_Int.

tts_lemma dependent_biggerset_general:
  assumes "S  UVS" and "finite S  dim S < card S"
  shows "dependent S"
    is finite_dimensional_vector_space.dependent_biggerset_general.

tts_lemma subset_le_dim:
  assumes "S  UVS" and "T  UVS" and "S  span T"
  shows "dim S  dim T"
    is finite_dimensional_vector_space.subset_le_dim.

tts_lemma linear_inj_imp_surj:
  assumes "xUVS. f x  UVS"
    and "linear_on UVS UVS (*s) (*s) f"
    and "inj_on f UVS"
  shows "f ` UVS = UVS"
    is finite_dimensional_vector_space.linear_inj_imp_surj.

tts_lemma linear_surj_imp_inj:
  assumes "xUVS. f x  UVS"
    and "linear_on UVS UVS (*s) (*s) f"
    and "f ` UVS = UVS"
  shows "inj_on f UVS"
    is finite_dimensional_vector_space.linear_surj_imp_inj.

tts_lemma linear_inverse_left:
  assumes "xUVS. f x  UVS"
    and "xUVS. f' x  UVS"
    and "linear_on UVS UVS (*s) (*s) f"
    and "linear_on UVS UVS (*s) (*s) f'"
  shows "(xUVS. (f  f') x = id x) = (xUVS. (f'  f) x = id x)"
    is finite_dimensional_vector_space.linear_inverse_left[unfolded fun_eq_iff].

tts_lemma left_inverse_linear:
  assumes "xUVS. f x  UVS"
    and "xUVS. g x  UVS"
    and "linear_on UVS UVS (*s) (*s) f"
    and "xUVS. (g  f) x = id x"
  shows "linear_on UVS UVS (*s) (*s) g"
    is finite_dimensional_vector_space.left_inverse_linear[unfolded fun_eq_iff].

tts_lemma right_inverse_linear:
  assumes "xUVS. f x  UVS"
    and "xUVS. g x  UVS"
    and "linear_on UVS UVS (*s) (*s) f"
    and "xUVS. (f  g) x = id x"
  shows "linear_on UVS UVS (*s) (*s) g"
    is finite_dimensional_vector_space.right_inverse_linear[unfolded fun_eq_iff].

end

end

context vector_space_pair_on 
begin

tts_context
  tts: (?'b to UM_1::'b set›) and (?'c to UM_2::'c set›) 
  sbterms: ((+)::?'b::ab_group_add?'b?'b to (+)::'b'b'b)
    and (?s1.0::?'a::field ?'b::ab_group_add?'b to (*s1)::'a'b'b)
    and (0::?'b::ab_group_add› to 0::'b) 
    and ((+)::?'c::ab_group_add?'c?'c to (+)::'c'c'c)
    and (?s2.0::?'a::field ?'c::ab_group_add?'c to (*s2)::'a'c'c)
    and (0::?'c::ab_group_add› to 0::'c)
  rewriting ctr_simps
  substituting VS1.ab_group_add_ow_axioms
    and VS1.vector_space_ow_axioms
    and VS2.ab_group_add_ow_axioms
    and VS2.vector_space_ow_axioms
    and implicitVS.vector_space_pair_ow_axioms
    and VS1.implicitM.module_ow_axioms
    and VS2.implicitM.module_ow_axioms
  eliminating ?a  UM_1 and ?B  UM_1 and ?a  UM_2 and ?B  UM_2 
    through auto
  applying  
    [
      OF 
        VS1.implicitM.carrier_ne VS2.implicitM.carrier_ne 
        VS1.implicitM.minus_closed' VS1.implicitM.uminus_closed' 
        VS2.implicitVS.minus_closed' VS2.implicitVS.uminus_closed',
      unfolded tts_implicit
    ]
begin

tts_lemma linear_add:
  assumes "xUM_1. f x  UM_2"
    and "b1  UM_1"
    and "b2  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "f (b1 + b2) = f b1 + f b2"
    is vector_space_pair.linear_add.

tts_lemma linear_scale:
  assumes "xUM_1. f x  UM_2"
    and "b  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "f (r *s1 b) = r *s2 f b"
    is vector_space_pair.linear_scale.
    
tts_lemma linear_neg:
  assumes "xUM_1. f x  UM_2"
    and "x  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "f (- x) = - f x"
    is vector_space_pair.linear_neg.
    
tts_lemma linear_diff:
  assumes "xUM_1. f x  UM_2"
    and "x  UM_1"
    and "y  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "f (x - y) = f x - f y"
    is vector_space_pair.linear_diff.
    
tts_lemma linear_sum:
  assumes "xUM_1. f x  UM_2"
    and "range g  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "f (sum g S) = (aS. f (g a))"
is vector_space_pair.linear_sum.

tts_lemma linear_inj_on_iff_eq_0:
  assumes "xUM_1. f x  UM_2"
    and "s  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS1.subspace s"
  shows "inj_on f s = (xs. f x = 0  x = 0)"
    is vector_space_pair.linear_inj_on_iff_eq_0.

tts_lemma linear_inj_iff_eq_0:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "inj_on f UM_1 = (xUM_1. f x = 0  x = 0)"
    is vector_space_pair.linear_inj_iff_eq_0.

tts_lemma linear_subspace_image:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS1.subspace S"
  shows "VS2.subspace (f ` S)"
    is vector_space_pair.linear_subspace_image.

tts_lemma linear_subspace_kernel:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "VS1.subspace {x  UM_1. f x = 0}"
    is vector_space_pair.linear_subspace_kernel.

tts_lemma linear_span_image:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "VS2.span (f ` S) = f ` VS1.span S"
    is vector_space_pair.linear_span_image.

tts_lemma linear_dependent_inj_imageD:
  assumes "xUM_1. f x  UM_2"
    and "s  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS2.dependent (f ` s)"
    and "inj_on f (VS1.span s)"
  shows "VS1.dependent s"
    is vector_space_pair.linear_dependent_inj_imageD.

tts_lemma linear_eq_0_on_span:
  assumes "xUM_1. f x  UM_2"
    and "b  UM_1"
    and "x  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "x. x  UM_1; x  b  f x = 0"
    and "x  VS1.span b"
  shows "f x = 0"
    is vector_space_pair.linear_eq_0_on_span.

tts_lemma linear_independent_injective_image:
  assumes "xUM_1. f x  UM_2"
    and "s  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "¬ VS1.dependent s"
    and "inj_on f (VS1.span s)"
  shows "¬ VS2.dependent (f ` s)"
    is vector_space_pair.linear_independent_injective_image.

tts_lemma linear_inj_on_span_independent_image:
  assumes "xUM_1. f x  UM_2"
    and "B  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "¬ VS2.dependent (f ` B)"
    and "inj_on f B"
  shows "inj_on f (VS1.span B)"
    is vector_space_pair.linear_inj_on_span_independent_image.

tts_lemma linear_inj_on_span_iff_independent_image:
  assumes "xUM_1. f x  UM_2"
    and "B  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "¬ VS2.dependent (f ` B)"
  shows "inj_on f (VS1.span B) = inj_on f B"
    is vector_space_pair.linear_inj_on_span_iff_independent_image.

tts_lemma linear_subspace_linear_preimage:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS2.subspace S"
  shows "VS1.subspace {x  UM_1. f x  S}"
    is vector_space_pair.linear_subspace_linear_preimage.

tts_lemma linear_spans_image:
  assumes "xUM_1. f x  UM_2"
    and "V  UM_1"
    and "B  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "V  VS1.span B"
  shows "f ` V  VS2.span (f ` B)"
    is vector_space_pair.linear_spans_image.

tts_lemma linear_spanning_surjective_image:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "UM_1  VS1.span S"
    and "f ` UM_1 = UM_2"
  shows "UM_2  VS2.span (f ` S)"
    is vector_space_pair.linear_spanning_surjective_image.

tts_lemma linear_eq_on_span:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "B  UM_1"
    and "x  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "linear_on UM_1 UM_2 (*s1) (*s2) g"
    and "x. x  UM_1; x  B  f x = g x"
    and "x  VS1.span B"
  shows "f x = g x"
    is vector_space_pair.linear_eq_on_span.

tts_lemma linear_compose_scale_right:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. c *s2 f x)"
    is vector_space_pair.linear_compose_scale_right.

tts_lemma linear_compose_add:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "linear_on UM_1 UM_2 (*s1) (*s2) g"
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. f x + g x)"
    is vector_space_pair.linear_compose_add.

tts_lemma linear_zero:
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. 0)"
    is vector_space_pair.linear_zero.

tts_lemma linear_compose_sub:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "linear_on UM_1 UM_2 (*s1) (*s2) g"
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. f x - g x)"
    is vector_space_pair.linear_compose_sub.

tts_lemma linear_compose_neg:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. - f x)"
    is vector_space_pair.linear_compose_neg.

tts_lemma linear_compose_scale:
  assumes "c  UM_2"
    and "linear_on UM_1 UNIV (*s1) (*) f"
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. f x *s2 c)"
    is vector_space_pair.linear_compose_scale.

tts_lemma linear_indep_image_lemma:
  assumes "xUM_1. f x  UM_2"
    and "B  UM_1"
    and "x  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "finite B"
    and "¬ VS2.dependent (f ` B)"
    and "inj_on f B"
    and "x  VS1.span B"
    and "f x = 0"
  shows "x = 0"
    is vector_space_pair.linear_indep_image_lemma.

tts_lemma linear_eq_on:
  assumes "xUM_1. f x  UM_2"
    and "xUM_1. g x  UM_2"
    and "x  UM_1"
    and "B  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "linear_on UM_1 UM_2 (*s1) (*s2) g"
    and "x  VS1.span B"
    and "b. b  UM_1; b  B  f b = g b"
  shows "f x = g x"
    is vector_space_pair.linear_eq_on.

tts_lemma linear_compose_sum:
  assumes "x. yUM_1. f x y  UM_2"
    and "xS. linear_on UM_1 UM_2 (*s1) (*s2) (f x)"
  shows "linear_on UM_1 UM_2 (*s1) (*s2) (λx. aS. f a x)"
    is vector_space_pair.linear_compose_sum.

tts_lemma linear_independent_extend_subspace:
  assumes "B  UM_1"
    and "xUM_1. f x  UM_2"
    and "¬ VS1.dependent B"
  shows 
    "x.
      (aUM_1. x a  UM_2)  
      linear_on UM_1 UM_2 (*s1) (*s2) x  
      (aB. x a = f a)  
      x ` UM_1 = VS2.span (f ` B)"
    given vector_space_pair.linear_independent_extend_subspace by auto

tts_lemma linear_independent_extend:
  assumes "B  UM_1"
    and "xUM_1. f x  UM_2"
    and "¬ VS1.dependent B"
  shows 
    "x. 
      (aUM_1. x a  UM_2)  
      (aB. x a = f a)  
      linear_on UM_1 UM_2 (*s1) (*s2) x"
    given vector_space_pair.linear_independent_extend by auto

tts_lemma linear_exists_left_inverse_on:
  assumes "xUM_1. f x  UM_2"
    and "V  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS1.subspace V"
    and "inj_on f V"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      x ` UM_2  V  
      (aV. x (f a) = a)  
      linear_on UM_2 UM_1 (*s2) (*s1) x"
    given vector_space_pair.linear_exists_left_inverse_on by auto

tts_lemma linear_exists_right_inverse_on:
  assumes "xUM_1. f x  UM_2"
    and "V  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS1.subspace V"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      x ` UM_2  V  
      (af ` V. f (x a) = a)  
      linear_on UM_2 UM_1 (*s2) (*s1) x"
    given vector_space_pair.linear_exists_right_inverse_on by auto

tts_lemma linear_inj_on_left_inverse:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "inj_on f (VS1.span S)"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      x ` UM_2  VS1.span S  
      (aVS1.span S. x (f a) = a)  
      linear_on UM_2 UM_1 (*s2) (*s1) x"
    given vector_space_pair.linear_inj_on_left_inverse by auto

tts_lemma linear_surj_right_inverse:
  assumes "xUM_1. f x  UM_2"
    and "T  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS2.span T  f ` VS1.span S"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      x ` UM_2  VS1.span S  
      (aVS2.span T. f (x a) = a)  
      linear_on UM_2 UM_1 (*s2) (*s1) x"
    given vector_space_pair.linear_surj_right_inverse by auto

tts_lemma finite_basis_to_basis_subspace_isomorphism:
  assumes "S  UM_1"
    and "T  UM_2"
    and "VS1.subspace S"
    and "VS2.subspace T"
    and "VS1.dim S = VS2.dim T"
    and "finite B"
    and "B  S"
    and "¬ VS1.dependent B"
    and "S  VS1.span B"
    and "card B = VS1.dim S"
    and "finite C"
    and "C  T"
    and "¬ VS2.dependent C"
    and "T  VS2.span C"
    and "card C = VS2.dim T"
  shows 
    "x. 
      (aUM_1. x a  UM_2)  
      linear_on UM_1 UM_2 (*s1) (*s2) x  
      x ` B = C  
      inj_on x S  x ` S = T"
    given vector_space_pair.finite_basis_to_basis_subspace_isomorphism by auto

tts_lemma linear_subspace_vimage:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "VS2.subspace S"
  shows "VS1.subspace (f -` S  UM_1)"
    is vector_space_pair.linear_subspace_vimage.

tts_lemma linear_injective_left_inverse:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "inj_on f UM_1"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      (aUM_1. (x  f) a = id a)  
      linear_on UM_2 UM_1 (*s2) (*s1) x"
    given vector_space_pair.linear_injective_left_inverse[unfolded fun_eq_iff]
  by auto

tts_lemma linear_surjective_right_inverse:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "f ` UM_1 = UM_2"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      (aUM_2. (f  x) a = id a)  
      linear_on UM_2 UM_1 (*s2) (*s1) x"
    given vector_space_pair.linear_surjective_right_inverse[unfolded fun_eq_iff]
  by auto

end

end

context finite_dimensional_vector_space_pair_1_on 
begin

tts_context
  tts: (?'b to UM_1::'b set›) and (?'c to UM_2::'c set›) 
  sbterms: ((+)::?'b::ab_group_add?'b?'b to (+)::'b'b'b)
    and (?s1.0::?'a::field ?'b::ab_group_add?'b to (*s1)::'a'b'b)
    and (0::?'b::ab_group_add› to 0::'b) 
    and ((+)::?'c::ab_group_add?'c?'c to (+)::'c'c'c)
    and (?s2.0::?'a::field ?'c::ab_group_add?'c to (*s2)::'a'c'c)
    and (0::?'c::ab_group_add› to 0::'c)
  rewriting ctr_simps
  substituting VS1.ab_group_add_ow_axioms
    and VS1.vector_space_ow_axioms
    and VS2.ab_group_add_ow_axioms
    and VS2.vector_space_ow_axioms
    and implicitVS.vector_space_pair_ow_axioms
    and VS1.implicitM.module_ow_axioms
    and VS2.implicitM.module_ow_axioms 
    and implicitVS.finite_dimensional_vector_space_pair_1_ow_axioms
  applying  
    [
      OF 
        VS1.implicitM.carrier_ne VS2.implicitM.carrier_ne 
        VS1.implicitVS.minus_closed' VS1.implicitVS.uminus_closed' 
        VS2.implicitVS.minus_closed' VS2.implicitVS.uminus_closed'
        VS1.basis_subset,
      unfolded tts_implicit
    ]
begin

tts_lemma lt_dim_image_eq:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "inj_on f (VS1.span S)"
  shows "VS2.dim (f ` S) = VS1.dim S"
    is finite_dimensional_vector_space_pair_1.dim_image_eq.

tts_lemma lt_dim_image_le:
  assumes "xUM_1. f x  UM_2"
    and "S  UM_1"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
  shows "VS2.dim (f ` S)  VS1.dim S"
    is finite_dimensional_vector_space_pair_1.dim_image_le.

end

end

context finite_dimensional_vector_space_pair_on 
begin

tts_context
  tts: (?'b to UM_1::'b set›) and (?'c to UM_2::'c set›) 
  sbterms: ((+)::?'b::ab_group_add?'b?'b to (+)::'b'b'b)
    and (?s1.0::?'a::field ?'b::ab_group_add?'b to (*s1)::'a'b'b)
    and (0::?'b::ab_group_add› to 0::'b) 
    and ((+)::?'c::ab_group_add?'c?'c to (+)::'c'c'c)
    and (?s2.0::?'a::field ?'c::ab_group_add?'c to (*s2)::'a'c'c)
    and (0::?'c::ab_group_add› to 0::'c)
  rewriting ctr_simps
  substituting VS1.ab_group_add_ow_axioms
    and VS1.vector_space_ow_axioms
    and VS2.ab_group_add_ow_axioms
    and VS2.vector_space_ow_axioms
    and implicitVS.vector_space_pair_ow_axioms
    and VS1.implicitM.module_ow_axioms
    and VS2.implicitM.module_ow_axioms 
    and implicitVS.finite_dimensional_vector_space_pair_ow_axioms
  applying  
    [
      OF 
        VS1.implicitM.carrier_ne VS2.implicitM.carrier_ne 
        VS1.implicitVS.minus_closed' VS1.implicitVS.uminus_closed' 
        VS2.implicitVS.minus_closed' VS2.implicitVS.uminus_closed'
        VS1.basis_subset VS2.basis_subset,
      unfolded tts_implicit
    ]
begin

tts_lemma linear_surjective_imp_injective:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "f ` UM_1 = UM_2"
    and "VS2.dim UM_2 = VS1.dim UM_1"
  shows "inj_on f UM_1"
    is finite_dimensional_vector_space_pair.linear_surjective_imp_injective.

tts_lemma linear_injective_imp_surjective:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "inj_on f UM_1"
    and "VS2.dim UM_2 = VS1.dim UM_1"
  shows "f ` UM_1 = UM_2"
    is finite_dimensional_vector_space_pair.linear_injective_imp_surjective.

tts_lemma linear_injective_isomorphism:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "inj_on f UM_1"
    and "VS2.dim UM_2 = VS1.dim UM_1"
  shows 
    "x. 
      (aUM_2. x a  UM_1)  
      linear_on UM_2 UM_1 (*s2) (*s1) x  
      (aUM_1. x (f a) = a)  
      (aUM_2. f (x a) = a)"
    given finite_dimensional_vector_space_pair.linear_injective_isomorphism
  by auto

tts_lemma linear_surjective_isomorphism:
  assumes "xUM_1. f x  UM_2"
    and "linear_on UM_1 UM_2 (*s1) (*s2) f"
    and "f ` UM_1 = UM_2"
    and "VS2.dim UM_2 = VS1.dim UM_1"
  shows 
    "x.
      (aUM_2. x a  UM_1)  
      linear_on UM_2 UM_1 (*s2) (*s1) x  
      (aUM_1. x (f a) = a)  
      (aUM_2. f (x a) = a)"
    given finite_dimensional_vector_space_pair.linear_surjective_isomorphism
  by auto

tts_lemma basis_to_basis_subspace_isomorphism:
  assumes "S  UM_1"
    and "T  UM_2"
    and "B  UM_1"
    and "C  UM_2"
    and "VS1.subspace S"
    and "VS2.subspace T"
    and "VS1.dim S = VS2.dim T"
    and "B  S"
    and "¬ VS1.dependent B"
    and "S  VS1.span B"
    and "card B = VS1.dim S"
    and "C  T"
    and "¬ VS2.dependent C"
    and "T  VS2.span C"
    and "card C = VS2.dim T"
  shows
    "x.
      (aUM_1. x a  UM_2) 
      linear_on UM_1 UM_2 (*s1) (*s2) x 
      x ` B = C 
      inj_on x S 
      x ` S = T"
  given finite_dimensional_vector_space_pair.basis_to_basis_subspace_isomorphism
  by auto

tts_lemma subspace_isomorphism:
  assumes "S  UM_1"
    and "T  UM_2"
    and "VS1.subspace S"
    and "VS2.subspace T"
    and "VS1.dim S = VS2.dim T"
  shows "x.
    (aUM_1. x a  UM_2) 
    (inj_on x S  x ` S = T) 
    linear_on UM_1 UM_2 (*s1) (*s2) x"
    given finite_dimensional_vector_space_pair.subspace_isomorphism by auto

end

end

text‹\newpage›

end

Theory VS_Conclusions

(* Title: Examples/Vector_Spaces/VS_Conclusions.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
theory VS_Conclusions
  imports
    VS_Prerequisites
    VS_Groups
    VS_Modules
    VS_Vector_Spaces
begin
end

Theory FNDS_Introduction

(* Title: Examples/TTS_Foundations/FNDS_Introduction.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
chapter‹TTS Foundations›
theory FNDS_Introduction
  imports "../Introduction"
begin
end

Theory FNDS_Set_Ext

(* Title: Examples/TTS_Foundations/Foundations/FNDS_Set_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Extension of the theory text‹Set›
theory FNDS_Set_Ext
  imports Main
begin

lemma Ex1_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "((A ===> (=)) ===> (=)) (λP. (∃!x(Collect (Domainp A)). P x)) Ex1"
  unfolding Ex1_def
  apply transfer_prover_start
  apply transfer_step+
  by blast

text‹\newpage›

end

Theory FNDS_Definite_Description

(* Title: Examples/TTS_Foundations/Foundations/FNDS_Definite_Description.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Definite description operator›
theory FNDS_Definite_Description
  imports Main
begin



subsection‹Definition and common properties›

definition The_on 
  where "The_on U P = 
    (if ∃!x. x  U  P x then Some (THE x. x  U  P x) else None)"

syntax 
  "_The_on" :: "pttrn  'a set  bool  'a option" 
  ("(THE _ on _./ _)" [0, 0, 10] 10)
translations "THE x on U. P"  "CONST The_on U (λx. P)"

print_translation [
    (
      const_syntax‹The_on›, 
      fn _ => fn [Ut, Abs abs] =>
        let val (x, t) = Syntax_Trans.atomic_abs_tr' abs
        in Syntax.const syntax_const‹_The_on› $ x $ Ut $ t end
    )
  ]

lemma The_on_UNIV_eq_The:
  assumes "∃!x. P x"
  obtains x where "(THE x on UNIV. P x) = Some x" and "(THE x. P x) = x"
  unfolding The_on_def by (simp add: assms)

lemma The_on_UNIV_None:
  assumes "¬(∃!x. P x)"
  shows "(THE x on UNIV. P x) = None"
  unfolding The_on_def by (simp add: assms)

lemma The_on_eq_The:
  assumes "∃!x. x  U  P x"
  obtains x where "(THE x on U. P x) = Some x" and "(THE x. x  U  P x) = x"
  unfolding The_on_def by (simp add: assms)

lemma The_on_None:
  assumes "¬(∃!x. x  U  P x)"
  shows "(THE x on U. P x) = None"
  unfolding The_on_def by (auto simp: assms)

lemma The_on_Some_equality[intro]:
  assumes "a  U" and "P a" and "x. x  U  P x  x = a"
  shows "(THE x on U. P x) = Some a"
proof-
  from assms have "∃!x. x  U  P x" by auto
  moreover have "(THE x. x  U  P x) = a" 
    apply standard using assms by blast+
  ultimately show ?thesis unfolding The_on_def by auto
qed  

lemma The_on_equality[intro]:
  assumes "a  U" and "P a" and "x. x  U  P x  x = a"
  shows "the (THE x on U. P x) = a"
  by (metis assms option.sel The_on_Some_equality)

lemma The_on_SomeI:
  assumes "a  U" and "P a" and "x. x  U  P x  x = a"
  obtains x where "(THE x on U. P x) = Some x" and "P x"
  using assms unfolding The_on_def by (meson that The_on_Some_equality)

lemma The_onI:
  assumes "a  U" and "P a" and "x. x  U  P x  x = a"
  shows "P (the (THE x on U. P x))"
  by (metis assms The_on_equality)

lemma The_on_SomeI': 
  assumes "∃!x. x  U  P x" 
  obtains x where "(THE x on U. P x) = Some x" and "P x"
  by (metis assms The_on_SomeI)

lemma The_onI':
  assumes "∃!x. x  U  P x" 
  shows "P (the (THE x on U. P x))"
  by (metis assms The_onI)

lemma The_on_SomeI2:
  assumes "a  U" 
    and "P a" 
    and "x. x  U  P x  x = a" 
    and "x. x  U  P x  Q x"
  obtains x where "(THE x on U. P x) = Some x" and "Q x"
  using assms by blast

lemma The_on_I2:
  assumes "a  U" 
    and "P a" 
    and "x. x  U  P x  x = a" 
    and "x. x  U  P x  Q x"
  shows "Q (the (THE x on U. P x))"
  by (metis assms The_on_equality)

lemma The_on_Some1I2:
  assumes "∃!x. x  U  P x" and "x. x  U  P x  Q x"
  obtains x where "(THE x on U. P x) = Some x" and "Q x"
  using assms by blast

lemma The_on1I2:
  assumes "∃!x. x  U  P x" and "x. x  U  P x  Q x"
  shows "Q (the (THE x on U. P x))"
  by (metis (mono_tags, hide_lams) The_on_I2 assms)

lemma The_on1_equality [elim?]: 
  assumes "∃!x. P x" and "a  U" and "P a" 
  shows "(THE x on U. P x) = Some a"
  using assms by blast

lemma the_sym_eq_trivial: 
  assumes "x  U" 
  shows "(THE y on U. x = y) = Some x"
  using assms by blast



subsection‹Transfer rules›

lemma The_on_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "(rel_set A ===> (A ===> (=)) ===> rel_option A) The_on The_on"
proof(intro rel_funI)
  fix U and U' and P :: "'a  bool" and P' :: "'b  bool"
  assume UU'[transfer_rule]: "rel_set A U U'" 
    and PP'[transfer_rule]: "(A ===> (=)) P P'" 
  show "rel_option A (THE x on U. P x) (THE x on U'. P' x)"
  proof(cases ∃!x'. x'  U'  P' x')
    case True show ?thesis
    proof-
      from True obtain x' where "x'  U'" and "P' x'" by clarsimp
      with True have The_on': "(THE x on U'. P' x) = Some x'" 
        unfolding The_on_def by auto
      from assms(2) obtain x where [transfer_rule]: "A x x'"
        unfolding right_total_def by auto
      from True have "y'U'. x'  y'  (¬P' y')" 
        by (auto simp: x'  U' P' x')
      then have "yU. x  y  (¬P y)" by transfer
      moreover from P' x' have "P x" by transfer
      ultimately have "∃!x. x  U  P x" 
        using UU' A x x' x'  U' assms(1) 
        by (auto dest: bi_uniqueDl rel_setD2)
      moreover from x'  U' have "x  U" by transfer 
      ultimately have The_on: "(THE x on U. P x) = Some x" 
        using P x unfolding The_on_def by auto
      show ?thesis unfolding The_on The_on' by transfer_prover
    qed
  next
    case nux: False show ?thesis
    proof(cases x'. x'  U'  P' x')
      case True show ?thesis 
      proof-  
        from True obtain x' where "x'  U'" and "P' x'" by clarsimp
        with nux True obtain y' where "y'  U'" and "P' y'" and "x'  y'" 
          by auto
        from assms(2) P' x' obtain x where [transfer_rule]: "A x x'"
          unfolding right_total_def by auto
        from assms(2) P' y' obtain y where [transfer_rule]: "A y y'" 
          unfolding right_total_def by auto
        from P' x' have "P x" by transfer
        moreover from P' y' have "P y" by transfer
        moreover from x'  y' have "x  y" by transfer
        ultimately have "∄!x. x  U  P x" 
          apply transfer 
          using UU' A x x' A y y' x'  U' y'  U' assms(1) 
          by (blast dest: bi_uniqueDl rel_setD2)
        then show ?thesis unfolding The_on_def by (auto simp: nux)
      qed
    next
      case False then show ?thesis
        unfolding The_on_def 
        using PP' UU' by (fastforce dest: rel_funD rel_setD1)
    qed
  qed
qed

text‹\newpage›

end

Theory FNDS_Auxiliary

(* Title: Examples/TTS_Foundations/Foundations/FNDS_Auxiliary.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Auxiliary›
theory FNDS_Auxiliary
  imports Types_To_Sets_Extension.ETTS_Auxiliary
begin



subsection‹Methods›

method ow_locale_transfer uses locale_defs = 
  (
    unfold locale_defs, 
    (
      (simp only: all_simps(6) all_comm, fold Ball_def) 
      | (fold Ball_def) 
      | tactic‹all_tac›
    ),
    transfer_prover_start,
    transfer_step+,
    rule refl
  )

text‹\newpage›

end

Theory Type_Simple_Orders

(* Title: Examples/TTS_Foundations/Orders/Type_Simple_Orders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Abstract orders on types›
theory Type_Simple_Orders
  imports
    "../Foundations/FNDS_Definite_Description"
    FNDS_Auxiliary
begin



subsection‹Background›


text‹
The results presented in this section were ported 
(with amendments and additions) from the theories text‹Orderings› 
and text‹Set_Interval› in the main library of Isabelle/HOL.
›



subsection‹Order operations›


text‹Abstract order operations.›

locale ord = 
  fixes le ls :: "['a, 'a]  bool"

locale ord_syntax = ord le ls for le ls :: "['a, 'a]  bool"
begin

notation
  le ("'(≤a')") and
  le (infix "a" 50) and
  ls ("'(<a')") and
  ls (infix "<a" 50)

abbreviation (input) ge (infix "a" 50)
  where "x a y  y a x"
abbreviation (input) gt (infix ">a" 50)
  where "x >a y  y <a x"

notation
  ge ("'(≥a')") and
  ge (infix "a" 50) and
  gt ("'(>a')") and
  gt (infix ">a" 50)

end

locale ord_dual = ord le ls for le ls :: "['a, 'a]  bool"
begin

interpretation ord_syntax .
sublocale dual: ord ge gt .

end


text‹Pairs.›

locale ord_pair = orda: ord lea lsa + ordb: ord leb lsb
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

sublocale rev: ord_pair leb lsb lea lsa .

end

locale ord_pair_syntax = ord_pair lea lsa leb lsb 
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

sublocale orda: ord_syntax lea lsa + ordb: ord_syntax leb lsb .

notation lea ('(≤a'))
  and lea (infix a 50) 
  and lsa ('(<a')) 
  and lsa (infix <a 50)
  and leb ('(≤b'))
  and leb (infix b 50) 
  and lsb ('(<b')) 
  and lsb (infix <b 50)

notation orda.ge ('(≥a')) 
  and orda.ge (infix a 50) 
  and orda.gt ('(>a')) 
  and orda.gt (infix >a 50)
  and ordb.ge ('(≥b')) 
  and ordb.ge (infix b 50) 
  and ordb.gt ('(>b')) 
  and ordb.gt (infix >b 50)

end

locale ord_pair_dual = ord_pair lea lsa leb lsb 
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

interpretation ord_pair_syntax .

sublocale ord_dual: ord_pair (≤a) (<a) (≥b) (>b) .
sublocale dual_ord: ord_pair (≥a) (>a) (≤b) (<b) .
sublocale dual_dual: ord_pair (≥a) (>a) (≥b) (>b) .

end



subsection‹Preorders›


subsubsection‹Definitions›


text‹Abstract preorders.›

locale preorder = ord le ls for le ls :: "['a, 'a]  bool" +
  assumes less_le_not_le: "ls x y  le x y  ¬ (le y x)"
    and order_refl[iff]: "le x x"
    and order_trans: "le x y  le y z  le x z"

locale preorder_dual = preorder le ls for le ls :: "['a, 'a]  bool"
begin

interpretation ord_syntax .

sublocale ord_dual .

sublocale dual: preorder ge gt 
  by standard (auto simp: less_le_not_le intro: order_trans)

end


text‹Pairs.›

locale ord_preorder = ord_pair lea lsa leb lsb + ordb: preorder leb lsb 
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"

locale ord_preorder_dual = ord_preorder lea lsa leb lsb
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

interpretation ord_pair_syntax .

sublocale ord_pair_dual .
sublocale ord_dual: ord_preorder (≤a) (<a) (≥b) (>b)
  by unfold_locales (auto simp: ordb.less_le_not_le intro: ordb.order_trans)
sublocale dual_ord: ord_preorder (≥a) (>a) (≤b) (<b) 
  by (rule ord_preorder_axioms)
sublocale dual_dual: ord_preorder (≥a) (>a) (≥b) (>b)
  by (rule ord_dual.ord_preorder_axioms)

end

locale preorder_pair = ord_preorder lea lsa leb lsb + orda: preorder lea lsa
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

sublocale rev: preorder_pair leb lsb lea lsa ..

end

locale preorder_pair_dual = preorder_pair lea lsa leb lsb
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

interpretation ord_pair_syntax .

sublocale ord_preorder_dual ..
sublocale ord_dual: preorder_pair (≤a) (<a) (≥b) (>b) ..
sublocale dual_ord: preorder_pair (≥a) (>a) (≤b) (<b) 
  by unfold_locales (auto intro: orda.order_trans simp: orda.less_le_not_le)
sublocale dual_dual: preorder_pair (≥a) (>a) (≥b) (>b) ..

end


subsubsection‹Results›

context preorder
begin

interpretation ord_syntax .


text‹Reflexivity.›

lemma eq_refl: 
  assumes "x = y"
  shows "x a y" 
  using assms by (rule ssubst) (rule order_refl)  
  
lemma less_irrefl[iff]: "¬ x <a x" by (simp add: less_le_not_le)

lemma less_imp_le: 
  assumes "x <a y"
  shows "x a y" 
  using assms by (simp add: less_le_not_le)

lemma strict_implies_not_eq: 
  assumes "a <a b"
  shows "a  b" 
  using assms by blast


text‹Asymmetry.›

lemma less_not_sym: 
  assumes "x <a y"
  shows "¬ (y <a x)"
  using assms by (simp add: less_le_not_le)

lemma asym: 
  assumes "a <a b" and "b <a a" 
  shows False
  using assms by (simp add: less_not_sym)

lemma less_asym: 
  assumes "x <a y" and "(¬ P  y <a x)" 
  shows P
  using assms by (auto dest: asym)
 

text‹Transitivity.›

lemma less_trans: 
  assumes "x <a y" and "y <a z" 
  shows "x <a z"
  using assms by (auto simp: less_le_not_le intro: order_trans)

lemma le_less_trans: 
  assumes "x a y" and "y <a z" 
  shows "x <a z"  
  using assms by (auto simp: less_le_not_le intro: order_trans)

lemma less_le_trans: 
  assumes "x <a y" and "y a z" 
  shows "x <a z"
  using assms by (auto simp: less_le_not_le intro: order_trans)

lemma less_imp_not_less: 
  assumes "x <a y"
  shows "(¬ y <a x)  True"
  using assms by (elim less_asym) simp

lemma less_imp_triv: 
  assumes "x <a y"
  shows "(y <a x  P)  True"
  using assms by (elim less_asym) simp

lemma less_asym': 
  assumes "a <a b" and "b <a a" 
  shows P 
  using assms by (rule less_asym)

end



subsection‹Partial orders›


subsubsection‹Definitions›


text‹Abstract partial orders.›

locale order = preorder le ls for le ls :: "['a, 'a]  bool" +
  assumes antisym: "le x y  le y x  x = y"

locale order_dual = order le ls for le ls :: "['a, 'a]  bool"
begin

interpretation ord_syntax .

sublocale preorder_dual ..

sublocale dual: order ge gt 
  unfolding order_def order_axioms_def
  apply unfold_locales
  apply(rule conjI)
  subgoal by (rule dual.preorder_axioms)
  subgoal by (simp add: antisym)
  done

end


text‹Pairs.›

locale ord_order = ord_preorder lea lsa leb lsb + ordb: order leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"

locale ord_order_dual = ord_order lea lsa leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

interpretation ord_pair_syntax .

sublocale ord_preorder_dual ..
sublocale ord_dual: ord_order (≤a) (<a) (≥b) (>b)
  by unfold_locales (simp add: ordb.antisym)
sublocale dual_ord: ord_order (≥a) (>a) (≤b) (<b) 
  by (rule ord_order_axioms)
sublocale dual_dual: ord_order (≥a) (>a) (≥b) (>b)
  by (rule ord_dual.ord_order_axioms)

end

locale preorder_order = ord_order lea lsa leb lsb + orda: preorder lea lsa
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool"
begin

sublocale preorder_pair ..

end

locale preorder_order_dual = preorder_order lea lsa leb lsb
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool" 
begin

interpretation ord_pair_syntax .

sublocale ord_order_dual ..
sublocale preorder_pair_dual ..
sublocale ord_dual: preorder_order (≤a) (<a) (≥b) (>b) .. 
sublocale dual_ord: preorder_order (≥a) (>a) (≤b) (<b) .. 
sublocale dual_dual: preorder_order (≥a) (>a) (≥b) (>b) ..

end

locale order_pair = preorder_order lea lsa leb lsb + orda: order lea lsa
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool" 
begin

sublocale rev: order_pair leb lsb lea lsa ..

end

locale order_pair_dual = order_pair lea lsa leb lsb
  for lea lsa :: "['a, 'a]  bool" and leb lsb :: "['b, 'b]  bool" 
begin

interpretation ord_pair_syntax .

sublocale preorder_order_dual ..
sublocale ord_dual: order_pair (≤a) (<a) (≥b) (>b) ..
sublocale dual_ord: order_pair (≥a) (>a) (≤b) (<b) 
  by unfold_locales (simp add: orda.antisym)
sublocale dual_dual: order_pair (≥a) (>a) (≥b) (>b) ..

end


subsubsection‹Results›

context order
begin

interpretation ord_syntax .


text‹Reflexivity.›

lemma less_le: "x <a y  x a y  x  y"
  by (auto simp: less_le_not_le intro: antisym)

lemma le_less: "x a y  x <a y  x = y" by (auto simp: less_le)

lemma le_imp_less_or_eq: 
  assumes "x a y"
  shows "x <a y  x = y" 
  using assms by (simp add: le_less)

lemma less_imp_not_eq: 
  assumes "x <a y"
  shows "(x = y)  False" 
  using assms by auto

lemma less_imp_not_eq2: 
  assumes "x <a y"
  shows "(y = x)  False"
  using assms by auto


text‹Transitivity.›

lemma neq_le_trans: 
  assumes "a  b" and "a a b" 
  shows "a <a b" 
  using assms by (simp add: less_le)

lemma le_neq_trans: 
  assumes "a a b" and "a  b" 
  shows "a <a b" 
  using assms by (simp add: less_le)

text‹Asymmetry.›

lemma eq_iff: "x = y  x a y  y a x" by (blast intro: antisym)

lemma antisym_conv: 
  assumes "y a x"
  shows "x a y  x = y" 
  using assms by (blast intro: antisym)


text‹Other results.›

lemma antisym_conv1: 
  assumes "¬ x <a y"
  shows "x a y  x = y"
  using assms by (simp add: le_less)

lemma antisym_conv2: 
  assumes "x a y"
  shows "¬ x <a y  x = y"
  using assms le_less by auto

lemma leD: 
  assumes "y a x"
  shows "¬ x <a y"
  using assms by (simp add: less_le_not_le)

end



subsection‹Dense orders›


text‹Abstract dense orders.›

locale dense_order = order le ls for le ls :: "['a, 'a]  bool" +
  assumes dense: "ls x y  (z. ls x z  ls z y)"

locale dense_order_dual = dense_order le ls for le ls :: "['a, 'a]  bool"
begin

interpretation ord_syntax .

sublocale order_dual ..

sublocale dual: dense_order ge gt 
  using dense by unfold_locales auto

end


text‹Pairs.›

locale ord_dense_order = ord_order lea lsa leb lsb + ordb: dense_order leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"

locale ord_dense_order_dual = ord_dense_order lea lsa leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

interpretation ord_pair_syntax .

sublocale ord_order_dual ..
sublocale ord_dual: ord_dense_order (≤a) (<a) (≥b) (>b)
  using ordb.dense by unfold_locales blast
sublocale dual_ord: ord_dense_order (≥a) (>a) (≤b) (<b) 
  by (rule ord_dense_order_axioms)
sublocale dual_dual: ord_dense_order (≥a) (>a) (≥b) (>b)
  by (rule ord_dual.ord_dense_order_axioms)

end

locale preorder_dense_order = 
  ord_dense_order lea lsa leb lsb + orda: preorder lea lsa
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

sublocale preorder_order ..

end

locale preorder_dense_order_dual = preorder_dense_order lea lsa leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

interpretation ord_pair_syntax .

sublocale ord_dense_order_dual ..
sublocale preorder_order_dual ..
sublocale ord_dual: preorder_dense_order (≤a) (<a) (≥b) (>b) ..
sublocale dual_ord: preorder_dense_order (≥a) (>a) (≤b) (<b) ..    
sublocale dual_dual: preorder_dense_order (≥a) (>a) (≥b) (>b) ..

end

locale order_dense_order = 
  preorder_dense_order lea lsa leb lsb + orda: order lea lsa
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

sublocale order_pair ..

end

locale order_dense_order_dual = order_dense_order lea lsa leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

interpretation ord_pair_syntax .

sublocale preorder_dense_order_dual ..
sublocale order_pair_dual ..
sublocale ord_dual: order_dense_order (≤a) (<a) (≥b) (>b) ..
sublocale dual_ord: order_dense_order (≥a) (>a) (≤b) (<b) ..    
sublocale dual_dual: order_dense_order (≥a) (>a) (≥b) (>b) ..

end

locale dense_order_pair = 
  order_dense_order lea lsa leb lsb + orda: dense_order lea lsa
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"

locale dense_order_pair_dual = dense_order_pair lea lsa leb lsb
  for lea lsa :: "'a  'a  bool" and leb lsb :: "'b  'b  bool"
begin

interpretation ord_pair_syntax .

sublocale order_dense_order_dual ..
sublocale ord_dual: dense_order_pair (≤a) (<a) (≥b) (>b) ..
sublocale dual_ord: dense_order_pair (≥a) (>a) (≤b) (<b) 
  using orda.dense by unfold_locales auto
sublocale dual_dual: dense_order_pair (≥a) (>a) (≥b) (>b) ..

end



subsection‹(Unique) top and bottom elements›


text‹Abstract extremum.›

locale extremum =
  fixes extremum :: 'a 

locale ord_extremum = ord le ls + extremum extremum 
  for le ls :: "'a  'a  bool" and extremum :: 'a


text‹Concrete syntax.›

locale bot = extremum bot for bot :: 'a
begin

notation bot ("")

end

locale top = extremum top for top :: 'a
begin

notation top ("")

end



subsection‹(Unique) top and bottom elements for partial orders›


subsubsection‹Definitions›


text‹Abstract partial order with extremum.›

locale order_extremum = ord_extremum le ls extremum + order le ls
  for le ls :: "'a  'a  bool"
  and extremum :: 'a  +
  assumes extremum[simp]: "le a extremum"


text‹Concrete syntax.›

locale order_bot = 
  order_dual le ls + 
  dual: order_extremum λx y. le y x λx y. ls y x bot + 
  bot bot 
  for le ls :: "'a  'a  bool" and bot :: 'a 

locale order_top = order_dual le ls + order_extremum le ls top + top top
  for le ls :: "'a  'a  bool" and top :: 'a 


subsubsection‹Results›

context order_extremum
begin

interpretation ord_syntax .

lemma extremum_uniqueI: 
  assumes "extremum a a"
  shows "a = extremum"
  using assms by (simp add: antisym)

lemma extremum_unique: "extremum a a  a = extremum"
  by (auto intro: antisym)

lemma extremum_strict[simp]: "¬ (extremum <a a)"
  by (fastforce simp: less_le_not_le)

lemma not_eq_extremum: "a  extremum  a <a extremum"
  using le_imp_less_or_eq by (auto intro: extremum)

end



subsection‹Partial orders without top or bottom elements›


text‹Abstract partial orders without top or bottom elements.›

locale no_extremum = order le ls for le ls :: "'a  'a  bool" +
  assumes gt_ex: "y. ls x y"


text‹Concrete syntax.›

locale no_top = order_dual le ls + no_extremum le ls 
  for le ls :: "'a  'a  bool"

locale no_bot = 
  order_dual le ls + 
  dual: no_extremum λx y. le y x λx y. ls y x 
  for le ls :: "'a  'a  bool"



subsection‹Least and greatest operators›

definition Least :: "['a set, ['a, 'a]  bool, 'a  bool]  'a option" 
  ((on _ with _ : «Least» _) [1000, 1000, 1000] 10) 
  where 
    "on U with op : «Least» P  (THE x on U. P x  (yU. P y  op x y))"

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]: "Domainp A = (λx. x  U)"
    and [transfer_rule]: "bi_unique A" "right_total A" 
  trp (?'a A)
  in Least_def

context ord_syntax
begin

abbreviation Least where "Least  Type_Simple_Orders.Least UNIV (≤a)"
abbreviation Greatest where "Greatest  Type_Simple_Orders.Least UNIV (≥a)"

lemmas Least_def = Least_def[of UNIV (≤a)]

end

context order
begin

interpretation ord_syntax .
                  
lemma Least_equality:
  assumes "P x" and "y. P y  x a y"
  shows "Least P = Some x"
  unfolding Least_def by (rule The_on_Some_equality) (auto simp: assms antisym)

lemma LeastI2_order:
  assumes "P x" 
    and "y. P y  x a y"
    and "x. P x  y. P y  x a y  Q x"
  obtains z where "Least P = Some z" and "Q z"
  unfolding Least_def using assms by (clarsimp simp: that Least_equality)

lemma Least_ex1:
  assumes "∃!x. P x  (y. P y  x a y)"
  obtains x where "Least P = Some x" and "P x" and "P z  x a z"
  using assms unfolding Least_def by (clarsimp simp: that Least_equality)

end



subsection‹min and max›

definition min :: "[['a, 'a]  bool, 'a, 'a]  'a" where
  "min le a b = (if le a b then a else b)"

ctr parametricity
  in min_def  

context ord_syntax
begin

abbreviation min where "min  Type_Simple_Orders.min (≤a)"
abbreviation max where "max  Type_Simple_Orders.min (≥a)"

end

context ord
begin

interpretation ord_syntax .

lemma min_absorb1: "x a y  min x y = x"
  unfolding min_def by simp

end


context order
begin

interpretation ord_syntax .

lemma min_absorb2: 
  assumes "y a x"
  shows "min x y = y"
  using assms unfolding min_def by (simp add: eq_iff)

end

context order_extremum
begin

interpretation ord_syntax .

lemma max_top[simp]: "max extremum x = extremum"
  by (simp add: ord.min_absorb1)

lemma max_top2[simp]: "max x extremum = extremum"
  unfolding min_def by (simp add: extremum_uniqueI)

lemma min_top[simp]: "min extremum x = x" by (simp add: min_absorb2)

lemma min_top2[simp]: "min x extremum = x"  by (simp add: min_def top_unique)

end



subsection‹Monotonicity›

definition mono :: 
  "['a set, ['a, 'a]  bool, ['b, 'b]  bool, 'a  'b]  bool" 
  ((on _ with _ _ : «mono» _) [1000, 1000, 999, 1000] 10) 
  where
    "on Ua with op1 op2 : «mono» f  xUa. yUa. op1 x y  op2 (f x) (f y)"

ctr parametricity
  in mono_def

context ord_pair_syntax
begin

abbreviation monoab 
  where "monoab  Type_Simple_Orders.mono UNIV (≤a) (≤b)"
abbreviation monoba 
  where "monoba  Type_Simple_Orders.mono UNIV (≤b) (≤a)"
abbreviation antimonoab 
  where "antimonoab  Type_Simple_Orders.mono UNIV (≤a) (≥b)"
abbreviation antimonoba 
  where "antimonoba  Type_Simple_Orders.mono UNIV (≤b) (≥a)"
abbreviation strict_monoab 
  where "strict_monoab  Type_Simple_Orders.mono UNIV (<a) (<b)"
abbreviation strict_monoba 
  where "strict_monoba  Type_Simple_Orders.mono UNIV (<b) (<a)"
abbreviation strict_antimonoab 
  where "strict_antimonoab  Type_Simple_Orders.mono UNIV (<a) (>b)"
abbreviation strict_antimonoba 
  where "strict_antimonoba  Type_Simple_Orders.mono UNIV (<b) (>a)"

end

context ord_pair
begin

interpretation ord_pair_syntax .

lemma monoI[intro?]: 
  assumes "x y. x a y  f x b f y" 
  shows "monoab f"
  unfolding mono_def using assms by simp

lemma monoD[dest?]:
  assumes "monoab f" and "x a y" 
  shows "f x b f y"
  using assms unfolding mono_def by simp

lemma monoE:
  assumes "monoab f" and "x a y"
  obtains "f x b f y"
  using assms unfolding mono_def by simp

lemma strict_monoI[intro?]: 
  assumes "x y. x <a y  f x <b f y" 
  shows "strict_monoab f"
  unfolding mono_def using assms by simp

lemma strict_monoD[dest?]:
  assumes "strict_monoab f" and "x <a y" 
  shows "f x <b f y"
  using assms unfolding mono_def by simp

lemma strict_monoE:
  assumes "strict_monoab f" and "x <a y"
  obtains "f x <b f y"
  using assms unfolding mono_def by simp

end

context order_pair
begin

interpretation ord_pair_syntax .

lemma strict_mono_mono[dest?]: 
  assumes "strict_monoab f"
  shows "monoab f"
proof(rule monoI)
  fix x y
  assume "x a y"
  show "f x b f y"
  proof (cases "x = y")
    case True then show ?thesis by simp
  next
    case False with x a y have "x <a y" by (simp add: orda.neq_le_trans)
    with assms strict_monoD have "f x <b f y" by simp
    then show ?thesis by (simp add: ordb.le_less)
  qed
qed

end



subsection‹Set intervals›

definition ray :: "['a set, ['a, 'a]  bool, 'a]  'a set" 
  ((on _ with _ : {..⊏_}) [1000, 1000, 1000] 10) 
  where "on U with op : {..⊏u}  {x  U. op x u}" 
definition interval :: 
  "['a set, ['a, 'a]  bool, ['a, 'a]  bool, 'a, 'a]  'a set"
  ((on _ with _ _ : {_⊏..⊏_}) [1000, 1000, 999, 1000, 1000] 10) 
  where "on U with op1 op2 : {l⊏..⊏u}  
    (on U with (λx y. op1 y x) : {..⊏l})  (on U with op2 : {..⊏u})"

lemma ray_transfer[transfer_rule]:
  includes lifting_syntax
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "(rel_set A ===> (A ===> A ===> (=)) ===> A ===> rel_set A) ray ray"
  unfolding ray_def
proof(intro rel_funI)
  fix S :: "'a set" and S' :: "'b set" 
    and le :: "['a, 'a]  bool" and le' :: "['b, 'b]  bool" 
    and u u'
  assume [transfer_rule]: "rel_set A S S'"
    and [transfer_rule]: "(A ===> A ===> (=)) le le'"
    and [transfer_rule]: "A u u'"
  show "rel_set A {xc  S. le xc u} {x  S'. le' x u'}"
  proof(intro rel_setI)
    show "x  {xc  S. le xc u}  x'{x  S'. le' x u'}. A x x'" for x
    proof-
      assume x: "x  {xc  S. le xc u}"
      then obtain x' where [transfer_rule]: "A x x'"  
        using ‹rel_set A S S' rel_setD1 by fastforce
      from x have "x'  {x  S'. le' x u'}" 
        apply transfer using A x x' by auto
      then show ?thesis by (auto simp: A x x')
    qed
    show "x'  {x  S'. le' x u'}  x{xc  S. le xc u}. A x x'" for x'
    proof-
      assume x': "x'  {x  S'. le' x u'}"
      then obtain x where [transfer_rule]: "A x x'"   
        using assms(2) by (auto elim: right_totalE)
      from x' have "x  {xc  S. le xc u}" by transfer auto
      then show ?thesis by (auto simp: A x x')
    qed  
  qed
qed

ctr relativization
  assumes [transfer_rule]: "right_total A" "bi_unique A"
  trp (?'a A)
  in interval_def

lemma interval_ge_le:
  "(on UNIV with (λx y. lea y x) (λx y. leb y x) : {l⊏..⊏h}) = 
    (on UNIV with leb lea : {h⊏..⊏l})"
  unfolding interval_def by auto

context ord_syntax  
begin

abbreviation lessThan ({..<a_}) 
  where "{..<au}  on UNIV with (<a) : {..⊏u}"
abbreviation atMost ({..≤a_}) 
  where "{..≤au}  on UNIV with (≤a) : {..⊏u}"
abbreviation greaterThan ({_<a..}) 
  where "{l<a..}  on UNIV with (>a) : {..⊏l}"
abbreviation atLeast ({_a..}) 
  where "{la..}  on UNIV with (≥a) : {..⊏l}"
abbreviation greaterThanLessThan ({_<a..<a_}) 
  where "{l<a..<au}  on UNIV with (<a) (<a) : {l⊏..⊏u}"
abbreviation atLeastLessThan ({_a..<a_}) 
  where "{la..<au}  on UNIV with (≤a) (<a) : {l⊏..⊏u}"
abbreviation greaterThanAtMost ({_<a..≤a_}) 
  where "{l<a..≤au}  on UNIV with (<a) (≤a) : {l⊏..⊏u}"
abbreviation atLeastAtMost ({_a..≤a_}) 
  where "{la..≤au}  on UNIV with (≤a) (≤a) : {l⊏..⊏u}"
abbreviation lessThanGreaterThan ({_>a..>a_}) 
  where "{l>a..>au}  on UNIV with (>a) (>a) : {l⊏..⊏u}"
abbreviation lessThanAtLeast ({_a..>a_}) 
  where "{la..>au}  on UNIV with (≥a) (>a) : {l⊏..⊏u}"
abbreviation atMostGreaterThan ({_>a..≥a_}) 
  where "{l>a..≥au}  on UNIV with (>a) (≥a) : {l⊏..⊏u}"
abbreviation atMostAtLeast ({_a..≥a_}) 
  where "{la..≥au}  on UNIV with (≥a) (≥a) : {l⊏..⊏u}"

end

context ord
begin

interpretation ord_syntax .

lemma lessThan_iff[iff]: "(i  {..<ak}) = (i <a k)"
  unfolding ray_def by simp

lemma atLeast_iff[iff]: "(i  {ka..}) = (k a i)"
  unfolding ray_def by simp

lemma greaterThanLessThan_iff[simp]: "(i  {l<a..<au}) = (l <a i  i <a u)"
  unfolding interval_def ray_def by simp

lemma atLeastLessThan_iff[simp]: "(i  {la..<au}) = (l a i  i <a u)"
  unfolding interval_def ray_def by simp

lemma greaterThanAtMost_iff[simp]: "(i  {l<a..≤au}) = (l <a i  i a u)"
  unfolding interval_def ray_def by simp

lemma atLeastAtMost_iff[simp]: "(i  {la..≤au}) = (l a i  i a u)"
  unfolding interval_def ray_def by simp

lemma greaterThanLessThan_eq: "{a<a..<ab} = {a<a..}  {..<ab}"
  unfolding interval_def ray_def by simp

end

context ord_pair_syntax
begin

notation orda.lessThan ({..<a_}) 
  and orda.atMost ({..≤a_}) 
  and orda.greaterThan ({_<a..}) 
  and orda.atLeast ({_a..}) 
  and orda.greaterThanLessThan ({_<a..<a_}) 
  and orda.atLeastLessThan ({_a..<a_}) 
  and orda.greaterThanAtMost ({_<a..≤a_}) 
  and orda.atLeastAtMost ({_a..≤a_}) 
  and orda.lessThanGreaterThan ({_>a..>a_})
  and orda.lessThanAtLeast ({_a..>a_}) 
  and orda.atMostGreaterThan ({_>a..≥a_}) 
  and orda.atMostAtLeast ({_a..≥a_}) 
  and ordb.lessThan ({..<b_}) 
  and ordb.atMost ({..≤b_}) 
  and ordb.greaterThan ({_<b..}) 
  and ordb.atLeast ({_b..}) 
  and ordb.greaterThanLessThan ({_<b..<b_}) 
  and ordb.atLeastLessThan ({_b..<b_}) 
  and ordb.greaterThanAtMost ({_<b..≤b_}) 
  and ordb.atLeastAtMost ({_b..≤b_})
  and ordb.lessThanGreaterThan ({_>b..>b_})
  and ordb.lessThanAtLeast ({_b..>b_}) 
  and ordb.atMostGreaterThan ({_>b..≥b_}) 
  and ordb.atMostAtLeast ({_b..≥b_})

end

context preorder
begin

interpretation ord_syntax .

lemma Ioi_le_Ico: "{a<a..}  {aa..}"
  unfolding ray_def by (fastforce simp: less_le_not_le)

end

context preorder
begin

interpretation ord_syntax .

interpretation preorder_dual le ls
  by (rule preorder_dual.intro[OF preorder_axioms])

lemma single_Diff_lessThan[simp]: "{k} - {..<ak} = {k}" by auto

lemma atLeast_subset_iff[iff]: "({xa..}  {ya..}) = (y a x)"
  by (auto intro: order_trans)

lemma atLeastatMost_empty[simp]: 
  assumes "b <a a"
  shows "{aa..≤ab} = {}"
  unfolding interval_def 
  using less_le_not_le assms
  by (metis Int_emptyI ord.lessThan_iff atLeast_iff order_trans)

lemma atLeastatMost_empty_iff[simp]: "{aa..≤ab} = {}  (¬ a a b)"
  by auto (blast intro: order_trans)

lemma atLeastatMost_empty_iff2[simp]: "{} = {aa..≤ab}  (¬ a a b)"
  by auto (blast intro: order_trans)

lemma atLeastLessThan_empty[simp]: 
  assumes "b a a" 
  shows "{aa..<ab} = {}"
  unfolding interval_def 
  using assms less_le_not_le 
  by (blast intro: order_trans)

lemma atLeastLessThan_empty_iff[simp]: "{aa..<ab} = {}  (¬ a <a b)"
  unfolding interval_def by (auto simp: le_less_trans ord.lessThan_iff)

lemma atLeastLessThan_empty_iff2[simp]: "{} = {aa..<ab}  (¬ a <a b)"
  unfolding interval_def by (auto simp: le_less_trans ord.lessThan_iff)

lemma greaterThanAtMost_empty[simp]: 
  assumes "l a k" 
  shows "{k<a..≤al} = {}" 
  using assms atLeastLessThan_empty[OF assms]
  unfolding 
    greaterThanAtMost_eq_atLeastAtMost_diff 
    atLeastLessThan_eq_atLeastAtMost_diff
  using le_less_trans by auto blast

lemma greaterThanAtMost_empty_iff[simp]: "{k<a..≤al} = {}  ¬ k <a l"
  by (auto simp: dual.le_less_trans)

lemma greaterThanAtMost_empty_iff2[simp]: "{} = {k<a..≤al}  ¬ k <a l"
  unfolding interval_def ray_def by (blast intro: less_le_trans)

lemma greaterThanLessThan_empty[simp]: 
  assumes "l a k" 
  shows "{k<a..<al} = {}"
  using assms by auto (blast intro: le_less_trans asym equals0I)

lemma atLeastatMost_subset_iff[simp]:
  "{aa..≤ab}  {ca..≤ad}  (¬ a a b)  c a a  b a d"
  by auto (blast intro: order_trans)+

lemma atLeastatMost_psubset_iff:
  "{aa..≤ab} < {ca..≤ad} 
    ((¬ a a b)  c a a  b a d  (c <a a  b <a d))  c a d"
  by (simp add: psubset_eq set_eq_iff less_le_not_le) 
    (blast intro: order_trans)

lemma Icc_subset_Ici_iff[simp]: 
  "{la..≤ah}  {l'a..} = (¬ l a h  l a l')"
  by (auto simp: subset_eq intro: order_trans)

lemma Icc_subset_Iic_iff[simp]: 
  "{la..≤ah}  {..≤ah'} = (¬ l a h  h a h')"
  unfolding interval_def ray_def by (blast intro: order_trans)+

lemma not_Ici_eq_empty[simp]: "{la..}  {}" by (auto simp: set_eq_iff)

lemmas not_empty_eq_Ici_eq_empty[simp] = not_Ici_eq_empty[symmetric]

lemma Iio_Int_singleton: "{..<ak}  {x} = (if x <a k then {x} else {})" by simp

lemma ivl_disj_int_one:
  "{..≤al}  {l<a..<au} = {}"
  "{..<al}  {la..<au} = {}"
  "{..≤al}  {l<a..≤au} = {}"
  "{..<al}  {la..≤au} = {}"
  "{l<a..≤au}  {u<a..} = {}"
  "{l<a..<au}  {ua..} = {}"
  "{la..≤au}  {u<a..} = {}"
  "{la..<au}  {ua..} = {}"
  using lessThan_iff dual.lessThan_iff by (auto simp: less_le_not_le)

lemma ivl_disj_int_two:
  "{l<a..<am}  {ma..<au} = {}"
  "{l<a..≤am}  {m<a..<au} = {}"
  "{la..<am}  {ma..<au} = {}"
  "{la..≤am}  {m<a..<au} = {}"
  "{l<a..<am}  {ma..≤au} = {}"
  "{l<a..≤am}  {m<a..≤au} = {}"
  "{la..<am}  {ma..≤au} = {}"
  "{la..≤am}  {m<a..≤au} = {}"
  using lessThan_iff by (auto simp: less_le_not_le)

end

context order
begin     

interpretation ord_syntax .

interpretation order_dual le ls
  by (rule order_dual.intro[OF order_axioms])

lemma atMost_Int_atLeast: "{..≤an}  {na..} = {n}"
  unfolding ray_def by (auto simp: eq_iff)

lemma atLeast_eq_iff[iff]: "({xa..} = {ya..}) = (x = y)" 
  unfolding ray_def using antisym by auto

lemma atLeastLessThan_eq_atLeastAtMost_diff: "{aa..<ab} = {aa..≤ab} - {b}"
  unfolding interval_def ray_def by (auto simp: less_imp_le le_less)

lemma greaterThanAtMost_eq_atLeastAtMost_diff: "{a<a..≤ab} = {aa..≤ab} - {a}"
  unfolding interval_def ray_def by (auto simp: less_imp_le le_less)

lemma atLeastAtMost_singleton[simp]: "{aa..≤aa} = {a}"
  using atMost_Int_atLeast by (fastforce simp: ray_def) 

lemma atLeastAtMost_singleton': 
  assumes "a = b"
  shows "{aa..≤ab} = {a}" 
  using assms by simp

lemma Icc_eq_Icc[simp]:
  "{la..≤ah} = {l'a..≤ah'} = (l = l'  h = h'  ¬ l a h  ¬ l' a h')"
  apply(rule iffI)
  subgoal by (metis antisym atLeastatMost_subset_iff eq_refl)
  subgoal using atLeastatMost_empty_iff by blast
  done

lemma atLeastAtMost_singleton_iff[simp]: "{aa..≤ab} = {c}  a = b  b = c"
proof
  assume "{aa..≤ab} = {c}"
  hence *: "¬ (¬ a a b)" unfolding atLeastatMost_empty_iff[symmetric] by simp
  with {aa..≤ab} = {c} have "c a a  b a c" by auto
  with * show "a = b  b = c" by (auto intro: antisym order_trans) 
qed simp

end

context order_extremum
begin

interpretation ord_syntax .

lemma atMost_eq_UNIV_iff: "{..≤ax} = UNIV  x = extremum"
  by (metis ord.lessThan_iff eq_iff UNIV_I UNIV_eq_I extremum)

end

context no_extremum
begin

interpretation ord_syntax .

interpretation order_dual le ls
  by (rule order_dual.intro[OF order_axioms])

lemma not_UNIV_le_Icc[simp]: "¬ UNIV  {la..≤ah}"
  using gt_ex[of h] by (auto simp: subset_eq less_le_not_le)

lemma not_UNIV_le_Iic[simp]: "¬ UNIV  {..≤ah}"
  using gt_ex[of h] by (auto simp: less_le_not_le)

lemma not_Ici_le_Icc[simp]: "¬ {la..}  {l'a..≤ah'}"
  using gt_ex[of h']
  by (auto simp: subset_eq less_le) 
    (blast dest: antisym_conv intro: order_trans)

lemma not_Ici_le_Iic[simp]: "¬ {la..}  {..≤ah'}"
proof
  assume "{la..}  {..≤ah'}"
  then have x: "l a x  x a h'" for x by auto
  from gt_ex obtain x where "h' <a x" by auto
  show False
  proof(cases l a x)
    case True show ?thesis 
      using x[OF True] less_le_not_le by (force simp: h' <a x)
  next
    case False
    obtain y where "x a y" and "y <a l"
      using h' <a x dual.less_le_trans by (blast intro: x less_imp_le)
    then have "x <a l" by (rule le_less_trans)
    then show ?thesis 
      using h' <a x less_le_not_le by (blast intro: x dual.less_trans)
  qed
qed

lemma not_UNIV_eq_Icc[simp]: "UNIV  {l'a..≤ah'}"
  using gt_ex by (auto simp: set_eq_iff less_le_not_le)
  
lemmas not_Icc_eq_UNIV[simp] = not_UNIV_eq_Icc[symmetric]

lemma not_UNIV_eq_Iic[simp]: "UNIV  {..≤ah'}"
  using gt_ex[of h'] not_UNIV_le_Iic by blast

lemmas not_Iic_eq_UNIV[simp] = not_UNIV_eq_Iic[symmetric]

lemma not_Icc_eq_Ici[simp]: "{la..≤ah}  {l'a..}"
  using not_Ici_le_Icc by blast

lemmas not_Ici_eq_Icc[simp] = not_Icc_eq_Ici[symmetric]

lemma not_Iic_eq_Ici[simp]: "{..≤ah}  {l'a..}"
  using not_Ici_le_Iic[of l' h] by blast

lemmas not_Ici_eq_Iic[simp] = not_Iic_eq_Ici[symmetric]

lemma greaterThan_non_empty[simp]: "{x<a..}  {}"
  using gt_ex[of x] unfolding ray_def by simp

end

context order
begin

interpretation ord_syntax .
interpretation order_pair le ls le ls ..
interpretation ord_pair_syntax le ls le ls .

lemma mono_image_least:
  assumes f_mono: "monoab f" 
    and f_img: "f ` {ma..<an} = {m'a..<an'}" 
    and "m <a n"
  shows "f m = m'"
proof -
  from f_img have "{m'a..<an'}  {}" by (force simp: assms(3))
  with f_img have "m'  f ` {ma..<an}" by auto
  then obtain k where "f k = m'" "m a k" by auto
  moreover have "m' a f m" 
    unfolding interval_def using f_img by (auto simp: assms(3))
  ultimately show "f m = m'"
    using f_mono by (auto dest: monoD intro: antisym)
qed

end



subsection‹Bounded sets›

definition bdd :: "['a set, ['a, 'a]  bool, 'a set]  bool"
  ((on _ with _ : «bdd» _) [1000, 1000, 1000] 10) 
  where "bdd U op A  (MU. x  A. op x M)"

ctr parametricity
  in bdd_def

context ord_syntax  
begin

abbreviation bdd_above where "bdd_above  bdd UNIV (≤a)"
abbreviation bdd_below where "bdd_below  bdd UNIV (≥a)"

end

context preorder
begin

interpretation ord_syntax .

interpretation preorder_dual ..

lemma bdd_aboveI[intro]: 
  assumes "x. x  A  x a M"
  shows "bdd_above A"
  using assms unfolding bdd_def by auto

lemma bdd_belowI[intro]: 
  assumes "x. x  A  m a x"
  shows "bdd_below A"
  using assms unfolding bdd_def by auto

lemma bdd_aboveI2: 
  assumes "x. x  A  f x a M"
  shows "bdd_above (f ` A)" 
  using assms by force

lemma bdd_belowI2: 
  assumes "x. x  A  m a f x"
  shows "bdd_below (f ` A)" 
  using assms by force

lemma bdd_above_empty[simp, intro]: "bdd_above {}"
  unfolding bdd_above_def by auto

lemma bdd_below_empty[simp, intro]: "bdd_below {}"
  unfolding bdd_below_def by auto

lemma bdd_above_mono: 
  assumes "bdd_above B" and "A  B" 
  shows "bdd_above A"
  using assms unfolding bdd_def by auto

lemma bdd_below_mono: 
  assumes "bdd_below B" and "A  B"
  shows "bdd_below A"
  using assms unfolding bdd_def by auto

lemma bdd_above_Int1[simp]: 
  assumes "bdd_above A"
  shows "bdd_above (A  B)"
  using assms by (auto simp: bdd_above_mono)

lemma bdd_above_Int2[simp]: 
  assumes "bdd_above B"
  shows "bdd_above (A  B)"
  using assms by (auto simp: bdd_above_mono)

lemma bdd_below_Int1[simp]: 
  assumes "bdd_below A"
  shows "bdd_below (A  B)"
  using assms by (auto simp: bdd_below_mono)

lemma bdd_below_Int2[simp]: 
  assumes "bdd_below B"
  shows "bdd_below (A  B)"
  using assms by (auto simp: bdd_below_mono)

lemma bdd_above_Ioo[simp, intro]: "bdd_above {a<a..<ab}" 
  by (auto intro!: less_imp_le)

lemma bdd_above_Ico[simp, intro]: "bdd_above {aa..<ab}" 
  by (auto intro!: less_imp_le)

lemma bdd_above_Iio[simp, intro]: "bdd_above {..<ab}"
  by (auto intro: less_imp_le)

lemma bdd_above_Ioc[simp, intro]: "bdd_above {a<a..≤ab}" by auto

lemma bdd_above_Icc[simp, intro]: "bdd_above {aa..≤ab}"
  by (auto intro: less_imp_le)

lemma bdd_above_Iic[simp, intro]: "bdd_above {..≤ab}"
  by (auto intro: less_imp_le)

lemma bdd_below_Ioo[simp, intro]: "bdd_below {a<a..<ab}"
  by (auto intro!: less_imp_le)

lemma bdd_below_Ioc[simp, intro]: "bdd_below {a<a..≤ab}"
  by (auto intro!: less_imp_le)

lemma bdd_below_Ioi[simp, intro]: "bdd_below {a<a..}"
  by (auto intro: less_imp_le)

lemma bdd_below_Ico[simp, intro]: "bdd_below {aa..<ab}" by auto

lemma bdd_below_Icc[simp, intro]: "bdd_below {aa..≤ab}" by auto

lemma bdd_below_Ici[simp, intro]: "bdd_below {aa..}"
  by (auto intro: less_imp_le)

end

context order_pair
begin

interpretation ord_pair_syntax .

lemma bdd_above_image_mono: 
  assumes "monoab f" and "orda.bdd_above A"
  shows "ordb.bdd_above (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

lemma bdd_below_image_mono: 
  assumes "monoab f" and "orda.bdd_below A" 
  shows "ordb.bdd_below (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

lemma bdd_above_image_antimono:
  assumes "antimonoab f" and "orda.bdd_below A" 
  shows "ordb.bdd_above (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

lemma bdd_below_image_antimono: 
  assumes "antimonoab f" and "orda.bdd_above A"   
  shows "ordb.bdd_below (f ` A)"
  using assms by (auto simp: bdd_def mono_def)

end

context order_extremum
begin

interpretation ord_syntax .
interpretation order_dual ..

lemma bdd_above_top[simp, intro!]: "bdd_above A"
  by (rule bdd_aboveI[of _ extremum]) simp

end

text‹\newpage›

end

Theory Set_Simple_Orders

(* Title: Examples/TTS_Foundations/Orders/Set_Simple_Orders.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Abstract orders on explicit sets›
theory Set_Simple_Orders
  imports 
    Type_Simple_Orders 
    "../Foundations/FNDS_Set_Ext"
begin



subsection‹Background›


text‹
Some of the results presented in this section were ported 
(with amendments and additions) from the theories text‹Orderings› 
and text‹Set_Interval› in the main library of Isabelle/HOL.
›



subsection‹Order operations›

locale ord_ow =
  fixes U :: "'a set" and le ls :: "['a, 'a]  bool" 
begin

tts_register_sbts le | U
proof-
  assume "Domainp AB = (λx. x  U)" "bi_unique AB" "right_total AB" 
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

tts_register_sbts ls | U
proof-
  assume "Domainp AB = (λx. x  U)" "bi_unique AB" "right_total AB" 
  from tts_AA_eq_transfer[OF this] show ?thesis by auto
qed

end

locale ord_syntax_ow = ord_ow U le ls
  for U :: "'a set" and le ls :: "['a, 'a]  bool" 
begin

notation
  le ("'(≤a')") and
  le (infix "a" 50) and
  ls ("'(<a')") and
  ls (infix "<a" 50)

abbreviation (input) ge (infix "a" 50)
  where "x a y  y a x"
abbreviation (input) gt (infix ">a" 50)
  where "x >a y  y <a x"

notation
  ge ("'(≥a')") and
  ge (infix "a" 50) and
  gt ("'(>a')") and
  gt (infix ">a" 50)

abbreviation Least where "Least  Type_Simple_Orders.Least U (≤a)"
abbreviation Greatest where "Greatest  Type_Simple_Orders.Least U (≥a)"

abbreviation min where "min  Type_Simple_Orders.min (≤a)"
abbreviation max where "max  Type_Simple_Orders.min (≥a)"

abbreviation lessThan ({..<a_}) where "{..<au}  on U with (<a) : {..⊏u}"
abbreviation atMost ({..≤a_}) where "{..≤au}  on U with (≤a) : {..⊏u}"
abbreviation greaterThan ({_<a..}) where "{l<a..}  on U with (>a) : {..⊏l}"
abbreviation atLeast ({_a..}) where "{la..}  on U with (≥a) : {..⊏l}"
abbreviation greaterThanLessThan ({_<a..<a_}) 
  where "{l<a..<au}  on U with (<a) (<a) : {l⊏..⊏u}"
abbreviation atLeastLessThan ({_a..<a_}) 
  where "{la..<au}  on U with (≤a) (<a) : {l⊏..⊏u}"
abbreviation greaterThanAtMost ({_<a..≤a_}) 
  where "{l<a..≤au}  on U with (<a) (≤a) : {l⊏..⊏u}"
abbreviation atLeastAtMost ({_a..≤a_}) 
  where "{la..≤au}  on U with (≤a) (≤a) : {l⊏..⊏u}"
abbreviation lessThanGreaterThan ({_>a..>a_}) 
  where "{l>a..>au}  on U with (>a) (>a) : {l⊏..⊏u}"
abbreviation lessThanAtLeast ({_a..>a_}) 
  where "{la..>au}  on U with (≥a) (>a) : {l⊏..⊏u}"
abbreviation atMostGreaterThan ({_>a..≥a_}) 
  where "{l>a..≥au}  on U with (>a) (≥a) : {l⊏..⊏u}"
abbreviation atMostAtLeast ({_a..≥a_}) 
  where "{la..≥au}  on U with (≥a) (≥a) : {l⊏..⊏u}"

abbreviation bdd_above where "bdd_above  bdd U (≤a)"
abbreviation bdd_below where "bdd_below  bdd U (≥a)"

end

locale ord_dual_ow = ord_syntax_ow U le ls
  for U :: "'a set" and le ls :: "['a, 'a]  bool"
begin

sublocale dual: ord_ow U ge gt .

end

locale ord_pair_ow = orda: ord_ow Ua lea lsa + ordb: ord_ow Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale rev: ord_pair_ow Ub leb lsb Ua lea lsa .

end

locale ord_pair_syntax_ow = ord_pair_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale orda: ord_syntax_ow Ua lea lsa + ordb: ord_syntax_ow Ub leb lsb .

notation lea ('(≤a'))
  and lea (infix a 50) 
  and lsa ('(<a')) 
  and lsa (infix <a 50)
  and leb ('(≤b'))
  and leb (infix b 50) 
  and lsb ('(<b')) 
  and lsb (infix <b 50)

notation orda.ge ('(≥a')) 
  and orda.ge (infix a 50) 
  and orda.gt ('(>a')) 
  and orda.gt (infix >a 50)
  and ordb.ge ('(≥b')) 
  and ordb.ge (infix b 50) 
  and ordb.gt ('(>b')) 
  and ordb.gt (infix >b 50)

abbreviation monoab 
  where "monoab  Type_Simple_Orders.mono Ua (≤a) (≤b)"
abbreviation monoba 
  where "monoba  Type_Simple_Orders.mono Ub (≤b) (≤a)"
abbreviation antimonoab 
  where "antimonoab  Type_Simple_Orders.mono Ua (≤a) (≥b)"
abbreviation antimonoba 
  where "antimonoba  Type_Simple_Orders.mono Ub (≤b) (≥a)"
abbreviation strict_monoab 
  where "strict_monoab  Type_Simple_Orders.mono Ua (<a) (<b)"
abbreviation strict_monoba 
  where "strict_monoba  Type_Simple_Orders.mono Ub (<b) (<a)"
abbreviation strict_antimonoab 
  where "strict_antimonoab  Type_Simple_Orders.mono Ua (<a) (>b)"
abbreviation strict_antimonoba 
  where "strict_antimonoba  Type_Simple_Orders.mono Ub (<b) (>a)"

notation orda.lessThan ({..<a_}) 
  and orda.atMost ({..≤a_}) 
  and orda.greaterThan ({_<a..}) 
  and orda.atLeast ({_a..}) 
  and orda.greaterThanLessThan ({_<a..<a_}) 
  and orda.atLeastLessThan ({_a..<a_}) 
  and orda.greaterThanAtMost ({_<a..≤a_}) 
  and orda.atLeastAtMost ({_a..≤a_}) 
  and orda.lessThanGreaterThan ({_>a..>a_})
  and orda.lessThanAtLeast ({_a..>a_}) 
  and orda.atMostGreaterThan ({_>a..≥a_}) 
  and orda.atMostAtLeast ({_a..≥a_}) 
  and ordb.lessThan ({..<b_}) 
  and ordb.atMost ({..≤b_}) 
  and ordb.greaterThan ({_<b..}) 
  and ordb.atLeast ({_b..}) 
  and ordb.greaterThanLessThan ({_<b..<b_}) 
  and ordb.atLeastLessThan ({_b..<b_}) 
  and ordb.greaterThanAtMost ({_<b..≤b_}) 
  and ordb.atLeastAtMost ({_b..≤b_})
  and ordb.lessThanGreaterThan ({_>b..>b_})
  and ordb.lessThanAtLeast ({_b..>b_}) 
  and ordb.atMostGreaterThan ({_>b..≥b_}) 
  and ordb.atMostAtLeast ({_b..≥b_})

end

locale ord_pair_dual_ow = ord_pair_syntax_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb

context ord_pair_dual_ow
begin

sublocale ord_dual: ord_pair_ow Ua (≤a) (<a) Ub (≥b) (>b) .
sublocale dual_ord: ord_pair_ow Ua (≥a) (>a) Ub (≤b) (<b) .
sublocale dual_dual: ord_pair_ow Ua (≥a) (>a) Ub (≥b) (>b) .

end


subsubsection‹Relativization›

context ord_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (?ls::?'a  ?'a  bool› to ls)
  rewriting ctr_simps
  eliminating through auto
begin

tts_lemma lessThan_iff:
  assumes "i  U" and "k  U"
  shows "(i  {..<ak}) = (i <a k)"
    is ord.lessThan_iff.
    
tts_lemma greaterThanLessThan_iff:
  assumes "i  U" and "l  U" and "u  U"
  shows "(i  {l<a..<au}) = (i <a u  l <a i)"
  is ord.greaterThanLessThan_iff.
    
tts_lemma greaterThanLessThan_eq:
  assumes "a  U" and "b  U"
  shows "{a<a..<ab} = {a<a..}  {..<ab}"
    is ord.greaterThanLessThan_eq.

end

tts_context
  tts: (?'a to U)
  sbterms: (?le::?'a  ?'a  bool› to le)
  rewriting ctr_simps
  eliminating through auto
begin

tts_lemma min_absorb1:
  assumes "x  U" and "y  U" and "x a y"
  shows "min x y = x"
  is ord.min_absorb1.
    
tts_lemma atLeast_iff:
  assumes "i  U" and "k  U"
  shows "(i  {ka..}) = (k a i)"
  is ord.atLeast_iff.

tts_lemma atLeastAtMost_iff:
  assumes "i  U" and "l  U" and "u  U"
  shows "(i  {la..≤au}) = (i a u  l a i)"
  is ord.atLeastAtMost_iff.

end

tts_context
  tts: (?'a to U)
  sbterms: (?le::?'a  ?'a  bool› to le)
    and (?ls::?'a  ?'a  bool› to ls)
   rewriting ctr_simps
 eliminating through auto
begin

tts_lemma atLeastLessThan_iff:
  assumes "i  U" and "l  U" and "u  U"
  shows "(i  {la..<au}) = (l a i  i <a u)"
    is ord.atLeastLessThan_iff.
    
tts_lemma greaterThanAtMost_iff:
  assumes "i  U" and "l  U" and "u  U"
  shows "(i  {l<a..≤au}) = (i a u  l <a i)"
  is ord.greaterThanAtMost_iff.

end

end

context ord_pair_ow
begin

interpretation ord_pair_syntax_ow .

tts_context
  tts: (?'a to Ua) and (?'b to Ub)
  sbterms: (?lea::?'a?'abool› to lea) and (?leb::?'b?'bbool› to leb)
  rewriting ctr_simps
  eliminating through (simp add: Type_Simple_Orders.mono_def)
begin

tts_lemma monoD:
  assumes "x  Ua" and "y  Ua" and "monoab f" and "x a y"
  shows "f x b f y"
  is ord_pair.monoD.
    
tts_lemma monoI:
  assumes "x y. x  Ua; y  Ua; x a y  f x b f y"
  shows "monoab f"
    is ord_pair.monoI.
    
tts_lemma monoE:
  assumes "x  Ua"
    and "y  Ua"
    and "monoab f"
    and "x a y"
    and "f x b f y  thesis"
  shows thesis
    is ord_pair.monoE.

end

tts_context
  tts: (?'a to Ua) and (?'b to Ub)
  sbterms: (?lsa::?'a?'abool› to lea) and (?lsb::?'b?'bbool› to leb)
  rewriting ctr_simps
  eliminating through (simp add: Type_Simple_Orders.mono_def)
begin

tts_lemma strict_monoD:
  assumes "x  Ua"
    and "y  Ua"
    and "monoab f"
    and "x a y"
  shows "f x b f y"
    is ord_pair.strict_monoD.
    
tts_lemma strict_monoI:
  assumes "x y. x  Ua; y  Ua; x a y  f x b f y"
  shows "monoab f"
    is ord_pair.strict_monoI.
    
tts_lemma strict_monoE:
  assumes "x  Ua"
    and "y  Ua"
    and "monoab f"
    and "x a y"
    and "f x b f y  thesis"
  shows thesis
    is ord_pair.strict_monoE.

end

end



subsection‹Preorders›


subsubsection‹Definitions and common properties›

locale preorder_ow = ord_ow U le ls 
  for U :: "'a set" and le ls +
  assumes less_le_not_le: " x  U; y  U   ls x y  le x y  ¬ (le y x)"
    and order_refl[iff]: "x  U  le x x"
    and order_trans: " x  U; y  U; z  U; le x y; le y z   le x z"

locale preorder_dual_ow = preorder_ow U le ls for U :: "'a set" and le ls
begin

sublocale ord_dual_ow .

sublocale dual: preorder_ow U ge gt 
  by standard (auto simp: less_le_not_le intro: order_trans)

end

locale ord_preorder_ow = 
  ord_pair_ow Ua lea lsa Ub leb lsb + ordb: preorder_ow Ub leb lsb 
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb

locale ord_preorder_dual_ow = ord_preorder_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale ord_pair_dual_ow .
sublocale ord_dual: ord_preorder_ow Ua (≤a) (<a) Ub (≥b) (>b)
  by unfold_locales (auto simp: ordb.less_le_not_le intro: ordb.order_trans)
sublocale dual_ord: ord_preorder_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  by (rule ord_preorder_ow_axioms)
sublocale dual_dual: ord_preorder_ow Ua (≥a) (>a) Ub (≥b) (>b)
  by (rule ord_dual.ord_preorder_ow_axioms)

end

locale preorder_pair_ow = 
  ord_preorder_ow Ua lea lsa Ub leb lsb + orda: preorder_ow Ua lea lsa
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale rev: preorder_pair_ow Ub leb lsb Ua lea lsa ..

end

locale preorder_pair_dual_ow = preorder_pair_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale ord_preorder_dual_ow ..
sublocale ord_dual: preorder_pair_ow Ua (≤a) (<a) Ub (≥b) (>b) ..
sublocale dual_ord: preorder_pair_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  by unfold_locales (auto intro: orda.order_trans simp: orda.less_le_not_le)
sublocale dual_dual: preorder_pair_ow Ua (≥a) (>a) Ub (≥b) (>b) ..

end


subsubsection‹Transfer rules›

lemma preorder_ow[ud_with]: "preorder = preorder_ow UNIV"
  unfolding preorder_def preorder_ow_def by simp

lemma ord_preorder_ow[ud_with]: "ord_preorder = ord_preorder_ow UNIV"
  unfolding ord_preorder_def ord_preorder_ow_def ud_with by simp

lemma preorder_pair_ow[ud_with]: 
  "preorder_pair = 
    (λlea lsa leb lsb. preorder_pair_ow UNIV lea lsa UNIV leb lsb)"
  unfolding preorder_pair_def preorder_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma preorder_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows 
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      preorder_ow preorder_ow"
  by (ow_locale_transfer locale_defs: preorder_ow_def)

lemma ord_preorder_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows 
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      ord_preorder_ow ord_preorder_ow"
  by (ow_locale_transfer locale_defs: ord_preorder_ow_def)

lemma preorder_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> 
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===> 
      (=)
    ) preorder_pair_ow preorder_pair_ow"
  by (ow_locale_transfer locale_defs: preorder_pair_ow_def)

end


subsubsection‹Relativization›

context preorder_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U) 
  sbterms: (?ls::?'a  ?'a  bool› to ls)
    and (?le::?'a  ?'a  bool› to le)
  rewriting ctr_simps
  substituting preorder_ow_axioms
  eliminating through auto
begin

tts_lemma less_irrefl:
  assumes "x  U"
  shows "¬ x <a x"
    is preorder.less_irrefl.

tts_lemma eq_refl:
  assumes "y  U" and "x = y"
  shows "x a y"
  is preorder.eq_refl.

tts_lemma less_imp_le:
  assumes "x  U" and "y  U" and "x <a y"
  shows "x a y"
    is preorder.less_imp_le.

tts_lemma strict_implies_not_eq:
  assumes "b  U" and "a <a b"
  shows "a  b"
    is preorder.strict_implies_not_eq.

tts_lemma less_not_sym:
  assumes "x  U" and "y  U" and "x <a y"
  shows "¬ y <a x"
    is preorder.less_not_sym.

tts_lemma not_empty_eq_Ici_eq_empty:
  assumes "l  U"
  shows "{}  {la..}"
    is preorder.not_empty_eq_Ici_eq_empty.

tts_lemma not_Ici_eq_empty:
  assumes "l  U"
  shows "{la..}  {}"
    is preorder.not_Ici_eq_empty.

tts_lemma asym:
  assumes "a  U" and "b  U" and "a <a b" and "b <a a"
  shows False
    is preorder.asym.

tts_lemma less_asym':
  assumes "a  U" and "b  U" and "a <a b" and "b <a a"
  shows P
    is preorder.less_asym'.

tts_lemma less_imp_not_less:
  assumes "x  U" and "y  U" and "x <a y"
  shows "(¬ y <a x) = True"
    is preorder.less_imp_not_less.

tts_lemma single_Diff_lessThan:
  assumes "k  U"
  shows "{k} - {..<ak} = {k}"
    is preorder.single_Diff_lessThan.

tts_lemma less_imp_triv:
  assumes "x  U" and "y  U" and "x <a y"
  shows "(y <a x  P) = True"
    is preorder.less_imp_triv.

tts_lemma ivl_disj_int_one:
  assumes "l  U" and "u  U"
  shows 
    "{..≤al}  {l<a..<au} = {}"
    "{..<al}  {la..<au} = {}"
    "{..≤al}  {l<a..≤au} = {}"
    "{..<al}  {la..≤au} = {}"
    "{l<a..≤au}  {u<a..} = {}"
    "{l<a..<au}  {ua..} = {}"
    "{la..≤au}  {u<a..} = {}"
    "{la..<au}  {ua..} = {}"
    is preorder.ivl_disj_int_one.

tts_lemma atLeastatMost_empty_iff2:
  assumes "a  U" and "b  U"
  shows "({} = {aa..≤ab}) = (¬ a a b)"
    is preorder.atLeastatMost_empty_iff2.

tts_lemma atLeastLessThan_empty_iff2:
  assumes "a  U" and "b  U"
  shows "({} = {aa..<ab}) = (¬ a <a b)"
    is preorder.atLeastLessThan_empty_iff2.

tts_lemma greaterThanAtMost_empty_iff2:
  assumes "k  U" and "l  U"
  shows "({} = {k<a..≤al}) = (¬ k <a l)"
    is preorder.greaterThanAtMost_empty_iff2.

tts_lemma atLeastatMost_empty_iff:
  assumes "a  U" and "b  U"
  shows "({aa..≤ab} = {}) = (¬ a a b)"
    is preorder.atLeastatMost_empty_iff.

tts_lemma atLeastLessThan_empty_iff:
  assumes "a  U" and "b  U"
  shows "({aa..<ab} = {}) = (¬ a <a b)"
    is preorder.atLeastLessThan_empty_iff.

tts_lemma greaterThanAtMost_empty_iff:
  assumes "k  U" and "l  U"
  shows "({k<a..≤al} = {}) = (¬ k <a l)"
    is preorder.greaterThanAtMost_empty_iff.

tts_lemma atLeastLessThan_empty:
  assumes "b  U" and "a  U" and "b a a"
  shows "{aa..<ab} = {}"
    is preorder.atLeastLessThan_empty.

tts_lemma greaterThanAtMost_empty:
  assumes "l  U" and "k  U" and "l a k"
  shows "{k<a..≤al} = {}"
    is preorder.greaterThanAtMost_empty.

tts_lemma greaterThanLessThan_empty:
  assumes "l  U" and "k  U" and "l a k"
  shows "{k<a..<al} = {}"
    is preorder.greaterThanLessThan_empty.

tts_lemma le_less_trans:
  assumes "x  U" and "y  U" and "z  U" and "x a y" and "y <a z"
  shows "x <a z"
    is preorder.le_less_trans.

tts_lemma atLeastatMost_empty:
  assumes "b  U" and "a  U" and "b <a a"
  shows "{aa..≤ab} = {}"
    is preorder.atLeastatMost_empty.

tts_lemma less_le_trans:
  assumes "x  U" and "y  U" and "z  U" and "x <a y" and "y a z"
  shows "x <a z"
    is preorder.less_le_trans.

tts_lemma less_trans:
  assumes "x  U" and "y  U" and "z  U" and "x <a y" and "y <a z"
  shows "x <a z"
    is preorder.less_trans.

tts_lemma ivl_disj_int_two:
  assumes "l  U" and "m  U" and "u  U"
  shows 
    "{l<a..<am}  {ma..<au} = {}"
    "{l<a..≤am}  {m<a..<au} = {}"
    "{la..<am}  {ma..<au} = {}"
    "{la..≤am}  {m<a..<au} = {}"
    "{l<a..<am}  {ma..≤au} = {}"
    "{l<a..≤am}  {m<a..≤au} = {}"
    "{la..<am}  {ma..≤au} = {}"
    "{la..≤am}  {m<a..≤au} = {}"
    is preorder.ivl_disj_int_two.

tts_lemma less_asym:
  assumes "x  U" and "y  U" and "x <a y" and "¬ P  y <a x"
  shows P
    is preorder.less_asym.

tts_lemma Iio_Int_singleton:
  assumes "k  U" and "x  U"
  shows "{..<ak}  {x} = (if x <a k then {x} else {})"
    is preorder.Iio_Int_singleton.

tts_lemma Ioi_le_Ico:
  assumes "a  U"
  shows "{a<a..}  {aa..}"
    is preorder.Ioi_le_Ico.

tts_lemma Icc_subset_Iic_iff:
  assumes "l  U" and "h  U" and "h'  U"
  shows "({la..≤ah}  {..≤ah'}) = (¬ l a h  h a h')"
    is preorder.Icc_subset_Iic_iff.

tts_lemma atLeast_subset_iff:
  assumes "x  U" and "y  U"
  shows "({xa..}  {ya..}) = (y a x)"
    is preorder.atLeast_subset_iff.

tts_lemma Icc_subset_Ici_iff:
  assumes "l  U" and "h  U" and "l'  U"
  shows "({la..≤ah}  {l'a..}) = (¬ l a h  l' a l)"
    is preorder.Icc_subset_Ici_iff.

tts_lemma atLeastatMost_subset_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({aa..≤ab}  {ca..≤ad}) = (¬ a a b  b a d  c a a)"
    is preorder.atLeastatMost_subset_iff.

tts_lemma atLeastatMost_psubset_iff:
  assumes "a  U" and "b  U" and "c  U" and "d  U"
  shows "({aa..≤ab}  {ca..≤ad}) = 
    (c a d  (¬ a a b  c a a  b a d  (c <a a  b <a d)))"
    is preorder.atLeastatMost_psubset_iff.

tts_lemma bdd_above_empty:
  assumes "U  {}"
  shows "bdd_above {}"
    is preorder.bdd_above_empty.

tts_lemma bdd_above_Iic:
  assumes "b  U"
  shows "bdd_above {..≤ab}"
    is preorder.bdd_above_Iic.

tts_lemma bdd_above_Iio:
  assumes "b  U"
  shows "bdd_above {..<ab}"
    is preorder.bdd_above_Iio.

tts_lemma bdd_below_empty:
  assumes "U  {}"
  shows "bdd_below {}"
    is preorder.bdd_below_empty.

tts_lemma bdd_above_Icc:
  assumes "a  U" and "b  U"
  shows "bdd_above {aa..≤ab}"
    is preorder.bdd_above_Icc.

tts_lemma bdd_above_Ico:
  assumes "a  U" and "b  U"
  shows "bdd_above {aa..<ab}"
    is preorder.bdd_above_Ico.

tts_lemma bdd_above_Ioc:
  assumes "a  U" and "b  U"
  shows "bdd_above {a<a..≤ab}"
    is preorder.bdd_above_Ioc.

tts_lemma bdd_above_Ioo:
  assumes "a  U" and "b  U"
  shows "bdd_above {a<a..<ab}"
    is preorder.bdd_above_Ioo.

tts_lemma bdd_above_Int1:
  assumes "A  U" and "B  U" and "bdd_above A"
  shows "bdd_above (A  B)"
    is preorder.bdd_above_Int1.

tts_lemma bdd_above_Int2:
  assumes "B  U" and "A  U" and "bdd_above B"
  shows "bdd_above (A  B)"
    is preorder.bdd_above_Int2.

tts_lemma bdd_below_Icc:
  assumes "a  U" and "b  U"
  shows "bdd_below {aa..≤ab}"
    is preorder.bdd_below_Icc.

tts_lemma bdd_below_Ico:
  assumes "a  U" and "b  U"
  shows "bdd_below {aa..<ab}"
    is preorder.bdd_below_Ico.

tts_lemma bdd_below_Ioc:
  assumes "a  U" and "b  U"
  shows "bdd_below {a<a..≤ab}"
    is preorder.bdd_below_Ioc.

tts_lemma bdd_below_Ioo:
  assumes "a  U" and "b  U"
  shows "bdd_below {a<a..<ab}"
    is preorder.bdd_below_Ioo.

tts_lemma bdd_below_Ici:
  assumes "a  U"
  shows "bdd_below {aa..}"
    is preorder.bdd_below_Ici.

tts_lemma bdd_below_Ioi:
  assumes "a  U"
  shows "bdd_below {a<a..}"
    is preorder.bdd_below_Ioi.

tts_lemma bdd_above_mono:
  assumes "B  U" and "bdd_above B" and "A  B"
  shows "bdd_above A"
    is preorder.bdd_above_mono.

tts_lemma bdd_aboveI:
  assumes "A  U" and "M  U" and "x. x  U; x  A  x a M"
  shows "bdd_above A"
    is preorder.bdd_aboveI.

tts_lemma bdd_aboveI2:
  assumes "range f  U" and "M  U" and "x. x  A  f x a M"
  shows "bdd_above (f ` A)"
    is preorder.bdd_aboveI2.

tts_lemma bdd_below_Int1:
  assumes "A  U" and "B  U" and "bdd_below A" 
  shows "bdd_below (A  B)"
    is preorder.bdd_below_Int1.

tts_lemma bdd_below_Int2:
  assumes "B  U" and "A  U" and "bdd_below B"
  shows "bdd_below (A  B)"
    is preorder.bdd_below_Int2.

tts_lemma bdd_belowI:
  assumes "A  U" and "m  U" and "x. x  U; x  A  m a x"
  shows "bdd_below A"
    is preorder.bdd_belowI.

tts_lemma bdd_below_mono:
  assumes "B  U" and "bdd_below B" and "A  B"
  shows "bdd_below A"
    is preorder.bdd_below_mono.

tts_lemma bdd_belowI2:
  assumes "m  U" and "range f  U" and "x. x  A  m a f x"
  shows "bdd_below (f ` A)"
    is preorder.bdd_belowI2[where 'b='d].

end
    
end



subsection‹Partial orders›

locale order_ow = preorder_ow U le ls 
  for U :: "'a set" and le ls +
  assumes antisym: "x  U  y  U  le x y  le y x  x = y"

locale order_dual_ow = order_ow U le ls 
  for U :: "'a set" and le ls
begin

sublocale preorder_dual_ow ..

sublocale dual: order_ow U ge gt 
  unfolding order_ow_def order_ow_axioms_def
  apply unfold_locales
  apply(rule conjI)
  subgoal by (rule dual.preorder_ow_axioms)
  subgoal by (simp add: antisym)
  done

end

locale ord_order_ow = 
  ord_preorder_ow Ua lea lsa Ub leb lsb + ordb: order_ow Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb

locale ord_order_dual_ow = ord_order_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale ord_preorder_dual_ow ..
sublocale ord_dual: ord_order_ow Ua (≤a) (<a) Ub (≥b) (>b)
  by unfold_locales (simp add: ordb.antisym)
sublocale dual_ord: ord_order_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  by (rule ord_order_ow_axioms)
sublocale dual_dual: ord_order_ow Ua (≥a) (>a) Ub (≥b) (>b)
  by (rule ord_dual.ord_order_ow_axioms)

end

locale preorder_order_ow = 
  ord_order_ow Ua lea lsa Ub leb lsb + orda: preorder_ow Ua lea lsa
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale preorder_pair_ow ..

end

locale preorder_order_dual_ow = preorder_order_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale ord_order_dual_ow ..
sublocale preorder_pair_dual_ow ..
sublocale ord_dual: preorder_order_ow Ua (≤a) (<a) Ub (≥b) (>b) .. 
sublocale dual_ord: preorder_order_ow Ua (≥a) (>a) Ub (≤b) (<b) .. 
sublocale dual_dual: preorder_order_ow Ua (≥a) (>a) Ub (≥b) (>b) ..

end

locale order_pair_ow = 
  preorder_order_ow Ua lea lsa Ub leb lsb + orda: order_ow Ua lea lsa
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale rev: order_pair_ow Ub leb lsb Ua lea lsa ..

end

locale order_pair_dual_ow = order_pair_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale preorder_order_dual_ow ..
sublocale ord_dual: order_pair_ow Ua (≤a) (<a) Ub (≥b) (>b) ..
sublocale dual_ord: order_pair_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  by unfold_locales (simp add: orda.antisym)
sublocale dual_dual: order_pair_ow Ua (≥a) (>a) Ub (≥b) (>b) ..

end


subsubsection‹Transfer rules›

lemma order_ow[ud_with]: "order = order_ow UNIV"
  unfolding 
    order_def order_ow_def order_axioms_def order_ow_axioms_def ud_with 
  by simp

lemma ord_order_ow[ud_with]: "ord_order = ord_order_ow UNIV"
  unfolding ord_order_def ord_order_ow_def ud_with by simp

lemma preorder_order_ow[ud_with]: 
  "preorder_order = 
    (λlea lsa leb lsb. preorder_order_ow UNIV lea lsa UNIV leb lsb)"
  unfolding preorder_order_def preorder_order_ow_def ud_with by simp

lemma order_pair_ow[ud_with]: 
  "order_pair = (λlea lsa leb lsb. order_pair_ow UNIV lea lsa UNIV leb lsb)"
  unfolding order_pair_def order_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      order_ow order_ow"
  by (ow_locale_transfer locale_defs: order_ow_def order_ow_axioms_def)

lemma ord_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      (=)
    ) ord_order_ow ord_order_ow"
  by (ow_locale_transfer locale_defs: ord_order_ow_def)

lemma preorder_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> 
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===> 
      (=)
    ) preorder_order_ow preorder_order_ow"
  by (ow_locale_transfer locale_defs: preorder_order_ow_def)

lemma order_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> 
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===> 
      (=)
    ) order_pair_ow order_pair_ow"
  by (ow_locale_transfer locale_defs: order_pair_ow_def)

end


subsubsection‹Relativization›

context order_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (?ls::?'a  ?'a  bool› to ls)
    and (?le::?'a  ?'a  bool› to le)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through auto
begin

tts_lemma atLeastAtMost_singleton:
  assumes "a  U"
  shows "{aa..≤aa} = {a}"
  is order.atLeastAtMost_singleton.
    
tts_lemma less_imp_not_eq:
  assumes "y  U" and "x <a y"
  shows "(x = y) = False"
  is order.less_imp_not_eq.
    
tts_lemma less_imp_not_eq2:
  assumes "y  U" and "x <a y"
  shows "(y = x) = False"
    is order.less_imp_not_eq2.

tts_lemma eq_iff:
  assumes "x  U" and "y  U"
  shows "(x = y) = (x a y  y a x)"
    is order.eq_iff.

tts_lemma le_less:
  assumes "x  U" and "y  U"
  shows "(x a y) = (x <a y  x = y)"
    is order.le_less.

tts_lemma min_absorb2:
  assumes "y  U" and "x  U" and "y a x"
  shows "min x y = y"
    is order.min_absorb2.

tts_lemma less_le:
  assumes "x  U" and "y  U"
  shows "(x <a y) = (x a y  x  y)"
    is order.less_le.

tts_lemma le_imp_less_or_eq:
  assumes "x  U" and "y  U" and "x a y"
  shows "x <a y  x = y"
    is order.le_imp_less_or_eq.

tts_lemma antisym_conv:
  assumes "y  U" and "x  U" and "y a x"
  shows "(x a y) = (x = y)"
    is order.antisym_conv.

tts_lemma le_neq_trans:
  assumes "a  U" and "b  U" and "a a b" and "a  b"
  shows "a <a b"
    is order.le_neq_trans.

tts_lemma neq_le_trans:
  assumes "a  U" and "b  U" and "a  b" and "a a b"
  shows "a <a b"
    is order.neq_le_trans.

tts_lemma atLeastAtMost_singleton':
  assumes "b  U" and "a = b"
  shows "{aa..≤ab} = {a}"
    is order.atLeastAtMost_singleton'.

tts_lemma atLeastLessThan_eq_atLeastAtMost_diff:
  assumes "a  U" and "b  U"
  shows "{aa..<ab} = {aa..≤ab} - {b}"
    is order.atLeastLessThan_eq_atLeastAtMost_diff.

tts_lemma greaterThanAtMost_eq_atLeastAtMost_diff:
  assumes "a  U" and "b  U"
  shows "{a<a..≤ab} = {aa..≤ab} - {a}"
    is order.greaterThanAtMost_eq_atLeastAtMost_diff.

tts_lemma atMost_Int_atLeast:
  assumes "n  U"
  shows "{..≤an}  {na..} = {n}"
    is order.atMost_Int_atLeast.

tts_lemma atLeast_eq_iff:
  assumes "x  U" and "y  U"
  shows "({xa..} = {ya..}) = (x = y)"
    is order.atLeast_eq_iff.

tts_lemma Least_equality:
  assumes "x  U" and "P x" 
    and "y. y  U; P y  x a y"
  shows "Least P = Some x"
    is order.Least_equality.

tts_lemma Icc_eq_Icc:
  assumes "l  U" and "h  U" and "l'  U" and "h'  U"
  shows "({la..≤ah} = {l'a..≤ah'}) = 
    (h = h'  l = l'  ¬ l' a h'  ¬ l a h)"
    is order.Icc_eq_Icc.

tts_lemma LeastI2_order:
  assumes "x  U"
    and "P x"
    and "y. y  U; P y  x a y"
    and "x. x  U; P x; yU. P y  x a y  Q x"
    and "z. z  U; Least P = Some z; Q z  thesis"
  shows thesis
    is order.LeastI2_order.

tts_lemma mono_image_least:
  assumes "xU. f x  U"
    and "m  U"
    and "n  U"
    and "m'  U"
    and "n'  U"
    and "on U with (≤a) (≤a) : «mono» f"
    and "f ` {ma..<an} = {m'a..<an'}"
    and "m <a n"
  shows "f m = m'"
    is order.mono_image_least.

tts_lemma antisym_conv1:
  assumes "x  U" and "y  U" and "¬ x <a y"
  shows "(x a y) = (x = y)"
    is order.antisym_conv1.

tts_lemma antisym_conv2:
  assumes "x  U" and "y  U" and "x a y"
  shows "(¬ x <a y) = (x = y)"
    is order.antisym_conv2.

tts_lemma leD:
  assumes "y  U" and "x  U" and "y a x"
  shows "¬ x <a y"
    is order.leD.

end

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating ?A  {} through auto
begin

tts_lemma atLeastAtMost_singleton_iff:
  assumes "a  U"
    and "b  U"
    and "c  U"
  shows "({aa..≤ab} = {c}) = (a = b  b = c)"
    is order.atLeastAtMost_singleton_iff.

end

tts_context
  tts: (?'a to U)
  sbterms: (?ls::?'a  ?'a  bool› to ls)
    and (?le::?'a  ?'a  bool› to le)
  rewriting ctr_simps
  substituting order_ow_axioms
  eliminating through auto
begin

tts_lemma Least_ex1:
  assumes "z  U"
    and "∃!x. x  U  P x  (yU. P y  x a y)"
    and "x. x  U; Least P = Some x; P x; P z  x a z  thesis"
  shows thesis
    is order.Least_ex1.
    
end    

end

context order_pair_ow
begin

interpretation ord_pair_syntax_ow .

tts_context
  tts: (?'a to Ua) and (?'b to Ub)
  sbterms: (?lsa::?'a  ?'a  bool› to lsa)
    and (?lea::?'a  ?'a  bool› to lea)
    and (?lsb::?'b  ?'b  bool› to lsb)
    and (?leb::?'b  ?'b  bool› to leb)
  rewriting ctr_simps
  substituting order_pair_ow_axioms
  eliminating through (auto simp: mono_def bdd_def)
begin

tts_lemma strict_mono_mono:
  assumes "xUa. f x  Ub" and "strict_monoab f"
  shows "monoab f"
    is order_pair.strict_mono_mono.

tts_lemma bdd_above_image_mono:
  assumes "xUa. f x  Ub" and "A  Ua" and "monoab f" and "orda.bdd_above A"
  shows "ordb.bdd_above (f ` A)"
    is order_pair.bdd_above_image_mono.

tts_lemma bdd_below_image_mono:
  assumes "xUa. f x  Ub" and "A  Ua" and "monoab f" and "orda.bdd_below A"
  shows "ordb.bdd_below (f ` A)"
    is order_pair.bdd_below_image_mono.

tts_lemma bdd_below_image_antimono:
  assumes "xUa. f x  Ub" 
    and "A  Ua" 
    and "antimonoab f" 
    and "orda.bdd_above A"
  shows "ordb.bdd_below (f ` A)"
    is order_pair.bdd_below_image_antimono.

tts_lemma bdd_above_image_antimono:
  assumes "xUa. f x  Ub"
    and "A  Ua"
    and "antimonoab f"
    and "orda.bdd_below A"
  shows "ordb.bdd_above (f ` A)"
    is order_pair.bdd_above_image_antimono.

end

end



subsection‹Dense orders›


subsubsection‹Definitions and common properties›

locale dense_order_ow = order_ow U le ls
  for U :: "'a set" and le ls +
  assumes dense: " x  U; y  U; ls x y   (zU. ls x z  ls z y)"

locale dense_order_dual_ow = dense_order_ow U le ls
  for U :: "'a set" and le ls
begin

interpretation ord_syntax_ow .

sublocale order_dual_ow ..

sublocale dual: dense_order_ow U ge gt 
  using dense by unfold_locales auto

end

locale ord_dense_order_ow = 
  ord_order_ow Ua lea lsa Ub leb lsb + ordb: dense_order_ow Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb

locale ord_dense_order_dual_ow = ord_dense_order_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb  
begin

sublocale ord_order_dual_ow ..
sublocale ord_dual: ord_dense_order_ow Ua (≤a) (<a) Ub (≥b) (>b)
  using ordb.dense by unfold_locales blast
sublocale dual_ord: ord_dense_order_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  by (rule ord_dense_order_ow_axioms)
sublocale dual_dual: ord_dense_order_ow Ua (≥a) (>a) Ub (≥b) (>b)
  by (rule ord_dual.ord_dense_order_ow_axioms)

end

locale preorder_dense_order_ow = 
  ord_dense_order_ow Ua lea lsa Ub leb lsb + orda: preorder_ow Ua lea lsa
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale preorder_order_ow ..

end

locale preorder_dense_order_dual_ow = 
  preorder_dense_order_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale ord_dense_order_dual_ow ..
sublocale preorder_order_dual_ow ..
sublocale ord_dual: preorder_dense_order_ow Ua (≤a) (<a) Ub (≥b) (>b) 
  ..
sublocale dual_ord: preorder_dense_order_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  ..    
sublocale dual_dual: preorder_dense_order_ow Ua (≥a) (>a) Ub (≥b) (>b) 
  ..

end

locale order_dense_order_ow = 
  preorder_dense_order_ow Ua lea lsa Ub leb lsb + orda: order_ow Ua lea lsa
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale order_pair_ow ..

end

locale order_dense_order_dual_ow = order_dense_order_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale preorder_dense_order_dual_ow ..
sublocale order_pair_dual_ow ..
sublocale ord_dual: order_dense_order_ow Ua (≤a) (<a) Ub (≥b) (>b) ..
sublocale dual_ord: order_dense_order_ow Ua (≥a) (>a) Ub (≤b) (<b) ..    
sublocale dual_dual: order_dense_order_ow Ua (≥a) (>a) Ub (≥b) (>b) ..

end

locale dense_order_pair_ow = 
  order_dense_order_ow Ua lea lsa Ub leb lsb + orda: dense_order_ow Ua lea lsa
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb

locale dense_order_pair_dual_ow = dense_order_pair_ow Ua lea lsa Ub leb lsb
  for Ua :: "'a set" and lea lsa and Ub :: "'b set" and leb lsb
begin

sublocale order_dense_order_dual_ow ..
sublocale ord_dual: dense_order_pair_ow Ua (≤a) (<a) Ub (≥b) (>b) ..
sublocale dual_ord: dense_order_pair_ow Ua (≥a) (>a) Ub (≤b) (<b) 
  using orda.dense by unfold_locales auto
sublocale dual_dual: dense_order_pair_ow Ua (≥a) (>a) Ub (≥b) (>b) ..

end


subsubsection‹Transfer rules›

lemma dense_order_ow[ud_with]: "dense_order = dense_order_ow UNIV"
  unfolding 
    dense_order_def dense_order_ow_def 
    dense_order_axioms_def dense_order_ow_axioms_def 
    ud_with 
  by simp

lemma ord_dense_order_ow[ud_with]: "ord_dense_order = ord_dense_order_ow UNIV"
  unfolding ord_dense_order_def ord_dense_order_ow_def ud_with by simp

lemma preorder_dense_order_ow[ud_with]: 
  "preorder_dense_order = 
    (λlea lsa leb lsb. preorder_dense_order_ow UNIV lea lsa UNIV leb lsb)"
  unfolding preorder_dense_order_def preorder_dense_order_ow_def ud_with 
  by simp

lemma order_dense_order_ow[ud_with]: 
  "order_dense_order = 
    (λlea lsa leb lsb. order_dense_order_ow UNIV lea lsa UNIV leb lsb)"
  unfolding order_dense_order_def order_dense_order_ow_def ud_with by simp

lemma dense_order_pair_ow[ud_with]: 
  "dense_order_pair = 
    (λlea lsa leb lsb. dense_order_pair_ow UNIV lea lsa UNIV leb lsb)"
  unfolding dense_order_pair_def dense_order_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma desne_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      dense_order_ow dense_order_ow"
  by 
    (
      ow_locale_transfer locale_defs: 
        dense_order_ow_def dense_order_ow_axioms_def
    )

lemma ord_dense_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===>
      (=)
    ) ord_dense_order_ow ord_dense_order_ow"
  by (ow_locale_transfer locale_defs: ord_dense_order_ow_def)

lemma preorder_dense_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> 
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===> 
      (=)
    ) preorder_dense_order_ow preorder_dense_order_ow"
  by (ow_locale_transfer locale_defs: preorder_dense_order_ow_def)

lemma order_dense_order_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> 
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===> 
      (=)
    ) order_dense_order_ow order_dense_order_ow"
  by (ow_locale_transfer locale_defs: order_dense_order_ow_def)

lemma dense_order_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> 
      rel_set B ===> (B ===> B ===> (=)) ===> (B ===> B ===> (=)) ===> 
      (=)
    ) dense_order_pair_ow dense_order_pair_ow"
  by (ow_locale_transfer locale_defs: dense_order_pair_ow_def)

end



subsection‹(Unique) top and bottom elements›

locale extremum_ow =
  fixes U :: "'a set" and extremum 
  assumes extremum_closed[simp]: "extremum  U"

locale bot_ow = extremum_ow U bot for U :: "'a set" and bot
begin

notation bot ("")

end

locale top_ow = extremum_ow U top for U :: "'a set" and top
begin

notation top ("")

end

locale ord_extremum_ow = ord_ow U le ls + extremum_ow U extremum 
  for U :: "'a set" and le ls extremum

locale order_extremum_ow = ord_extremum_ow U le ls extremum + order_ow U le ls
  for U :: "'a set" and le ls extremum +
  assumes extremum[simp]: "a  U  le a extremum"

locale order_bot_ow = 
  order_dual_ow U le ls + dual: order_extremum_ow U ge gt bot + bot_ow U bot 
  for U :: "'a set" and le ls bot

locale order_top = 
  order_dual_ow U le ls + order_extremum_ow U le ls top + top_ow U top
  for U :: "'a set" and le ls top


subsubsection‹Transfer rules›

lemma order_extremum_ow[ud_with]: "order_extremum = order_extremum_ow UNIV"
  unfolding 
    order_extremum_def order_extremum_axioms_def 
    order_extremum_ow_def order_extremum_ow_axioms_def
    ord_extremum_ow_def extremum_ow_def
    ud_with 
  by simp

context
  includes lifting_syntax
begin

lemma extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> A ===> (=)) extremum_ow extremum_ow"
  by (ow_locale_transfer locale_defs: extremum_ow_def)

lemma ord_extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> A ===> (=)) ord_extremum_ow ord_extremum_ow"
  by (ow_locale_transfer locale_defs: ord_extremum_ow_def)

lemma order_extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(
      rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> A ===> 
      (=)
    ) order_extremum_ow order_extremum_ow"
  by 
    (
      ow_locale_transfer locale_defs: 
        order_extremum_ow_def order_extremum_ow_axioms_def
    )

end


subsubsection‹Relativization›

context order_extremum_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (?le::?'a  ?'a  bool› to le)
    and (?ls::?'a  ?'a  bool› to ls)
  rewriting ctr_simps
  substituting order_extremum_ow_axioms
  eliminating through force
begin

tts_lemma extremum_strict:
  assumes "a  U"
  shows "¬ extremum <a a"
    is order_extremum.extremum_strict.
    
tts_lemma bdd_above_top:
  assumes "A  U"
  shows "bdd_above A"
    is order_extremum.bdd_above_top.
    
tts_lemma min_top:
  assumes "x  U"
  shows "min extremum x = x"
  is order_extremum.min_top.

tts_lemma min_top2:
  assumes "x  U"
  shows "min x extremum = x"
  is order_extremum.min_top2.
    
tts_lemma extremum_unique:
  assumes "a  U"
  shows "(extremum a a) = (a = extremum)"
is order_extremum.extremum_unique.
    
tts_lemma not_eq_extremum:
  assumes "a  U"
  shows "(a  extremum) = (a <a extremum)"
  is order_extremum.not_eq_extremum.
    
tts_lemma extremum_uniqueI:
  assumes "a  U" and "extremum a a"
  shows "a = extremum"
    is order_extremum.extremum_uniqueI.
    
tts_lemma max_top:
  assumes "x  U"
  shows "max extremum x = extremum"
    is order_extremum.max_top.

tts_lemma max_top2:
  assumes "x  U"
  shows "max x extremum = extremum"
    is order_extremum.max_top2.

tts_lemma atMost_eq_UNIV_iff:
  assumes "x  U"
  shows "({..≤ax} = U) = (x = extremum)"
    is order_extremum.atMost_eq_UNIV_iff.

end

end



subsection‹Absence of top or bottom elements›

locale no_extremum_ow = order_ow U le ls for U :: "'a set" and le ls +
  assumes gt_ex: "x  U  yU. ls x y"

locale no_top_ow = order_dual_ow U le ls + no_extremum_ow U le ls 
  for U :: "'a set" and le ls

locale no_bot_ow = order_dual_ow U le ls + dual: no_extremum_ow U ge gt 
  for U :: "'a set" and le ls

subsubsection‹Transfer rules›

lemma no_extremum_ow[ud_with]: "no_extremum = no_extremum_ow UNIV"
  unfolding 
    no_extremum_def no_extremum_ow_def 
    no_extremum_axioms_def no_extremum_ow_axioms_def
    ud_with
  by simp

context
  includes lifting_syntax
begin

lemma no_extremum_ow_axioms_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(rel_set A ===> (A ===> A ===> (=)) ===> (=)) 
      no_extremum_ow_axioms no_extremum_ow_axioms"
  by (ow_locale_transfer locale_defs:  no_extremum_ow_axioms_def)

lemma no_extremum_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows 
    "(rel_set A ===> (A ===> A ===> (=)) ===> (A ===> A ===> (=)) ===> (=)) 
      no_extremum_ow no_extremum_ow"
  by (ow_locale_transfer locale_defs: no_extremum_ow_def)

end


subsubsection‹Relativization›

lemma right_total_UNIV_transfer'[transfer_rule]: 
  assumes "right_total A" and "Domainp A = (λx. x  U)"
  shows "rel_set A U UNIV"
  using assms right_total_UNIV_transfer by fastforce

context no_extremum_ow
begin

interpretation ord_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (?le::?'a  ?'a  bool› to le)
    and (?ls::?'a  ?'a  bool› to ls)
  rewriting ctr_simps
  substituting no_extremum_ow_axioms
  eliminating through force
begin

tts_lemma not_UNIV_eq_Iic:
  assumes "h'  U"
  shows "U  {..≤ah'}"
  is no_extremum.not_UNIV_eq_Iic.

tts_lemma not_Iic_eq_UNIV:
  assumes "h'  U"
  shows "{..≤ah'}  U"
    is no_extremum.not_Iic_eq_UNIV.

tts_lemma not_UNIV_le_Iic:
  assumes "h  U"
  shows "¬ U  {..≤ah}"
    is no_extremum.not_UNIV_le_Iic.

tts_lemma not_UNIV_eq_Icc:
  assumes "l'  U" and "h'  U"
  shows "U  {l'a..≤ah'}"
    is no_extremum.not_UNIV_eq_Icc.

tts_lemma not_Icc_eq_UNIV:
  assumes "l'  U" and "h'  U"
  shows "{l'a..≤ah'}  U"
    is no_extremum.not_Icc_eq_UNIV.

tts_lemma not_UNIV_le_Icc:
  assumes "l  U" and "h  U"
  shows "¬ U  {la..≤ah}"
    is no_extremum.not_UNIV_le_Icc.

tts_lemma greaterThan_non_empty:
  assumes "x  U"
  shows "{x<a..}  {}"
    is no_extremum.greaterThan_non_empty.

tts_lemma not_Iic_eq_Ici:
  assumes "h  U" and "l'  U"
  shows "{..≤ah}  {l'a..}"
    is no_extremum.not_Iic_eq_Ici.

tts_lemma not_Ici_eq_Iic:
  assumes "l'  U" and "h  U"
  shows "{l'a..}  {..≤ah}"
    is no_extremum.not_Ici_eq_Iic.

tts_lemma not_Ici_le_Iic:
  assumes "l  U" and "h'  U"
  shows "¬ {la..}  {..≤ah'}"
    is no_extremum.not_Ici_le_Iic.

tts_lemma not_Icc_eq_Ici:
  assumes "l  U" and "h  U" and "l'  U"
  shows "{la..≤ah}  {l'a..}"
    is no_extremum.not_Icc_eq_Ici.

tts_lemma not_Ici_eq_Icc:
  assumes "l'  U" and "l  U" and "h  U"
  shows "{l'a..}  {la..≤ah}"
    is no_extremum.not_Ici_eq_Icc.

tts_lemma not_Ici_le_Icc:
  assumes "l  U" and "l'  U" and "h'  U"
  shows "¬ {la..}  {l'a..≤ah'}"
    is no_extremum.not_Ici_le_Icc.

end

end

declare right_total_UNIV_transfer'[transfer_rule del]

text‹\newpage›

end

Theory Type_Semigroups

(* Title: Examples/TTS_Foundations/Algebra/Type_Semigroups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Abstract semigroups on types›
theory Type_Semigroups
  imports Main
begin



subsection‹Background›

text‹The results presented in this section were ported 
(with amendments and additions) from the theory text‹Groups› in the main 
library of Isabelle/HOL.›



subsection‹Preliminaries›

named_theorems tts_ac_simps "assoc. and comm. simplification rules"
  and tts_algebra_simps "algebra simplification rules"
  and tts_field_simps "algebra simplification rules for fields"



subsection‹Binary operations›


text‹Abstract operation.›

locale binary_op = 
  fixes f :: "'a  'a  'a"

locale binary_op_syntax = binary_op f for f :: "'a  'a  'a"
begin

notation f (infixl a 65)

end


text‹Concrete syntax.›

locale plus = binary_op plus for plus :: "'a  'a  'a"
begin

notation plus (infixl +a 65)

end

locale minus = binary_op minus for minus :: "'a  'a  'a"
begin

notation minus (infixl -a 65)

end

locale times = binary_op times for times :: "'a  'a  'a"
begin

notation times (infixl *a 70)

end

locale divide = binary_op divide for divide :: "'a  'a  'a"
begin

notation divide (infixl '/a 70)

end


text‹Pairs.›

locale binary_op_pair = alga: binary_op fa + algb: binary_op fb
  for fa :: "'a  'a  'a" and fb :: "'b  'b  'b"

locale binary_op_pair_syntax = binary_op_pair fa fb
  for fa :: "'a  'a  'a" and fb :: "'b  'b  'b"
begin

notation fa (infixl a 65)
notation fb (infixl b 65)

end



subsection‹Simple semigroups›


subsubsection‹Definitions›


text‹Abstract semigroups.›

locale semigroup = binary_op f for f :: "'a  'a  'a" +
  assumes assoc[tts_ac_simps, tts_algebra_simps]: "f (f a b) c = f a (f b c)"

locale semigroup_syntax = binary_op_syntax f for f :: "'a  'a  'a"


text‹Concrete syntax.›

locale semigroup_add = semigroup plus for plus :: "'a  'a  'a"
begin

sublocale plus plus .

end

locale semigroup_mult = semigroup times for times :: "'a  'a  'a"
begin

sublocale times times .

end


text‹Pairs.›

locale semigroup_pair = alga: semigroup fa + algb: semigroup fb 
  for fa :: "'a  'a  'a" and fb :: "'b  'b  'b"
begin

sublocale binary_op_pair fa fb .
sublocale rev: semigroup_pair fb fa ..

end

locale semigroup_pair_syntax = binary_op_pair_syntax



subsection‹Commutative semigroups›


subsubsection‹Definitions›


text‹Abstract commutative semigroup.›

locale comm_semigroup = semigroup f for f :: "'a  'a  'a" +
  assumes commute[tts_ac_simps, tts_algebra_simps]: "f a b = f b a"

locale comm_semigroup_syntax = semigroup_syntax


text‹Concrete syntax.›

locale comm_semigroup_add = comm_semigroup plus for plus :: "'a  'a  'a"
begin

sublocale semigroup_add plus ..

end

locale comm_semigroup_mult = comm_semigroup times for times :: "'a  'a  'a"
begin

sublocale semigroup_mult times ..

end


text‹Pairs.›

locale comm_semigroup_pair = alga: comm_semigroup fa + algb: comm_semigroup fb 
  for fa :: "'a  'a  'a" and fb :: "'b  'b  'b"
begin

sublocale semigroup_pair fa fb ..
sublocale rev: comm_semigroup_pair fb fa ..

end

locale comm_semigroup_pair_syntax = semigroup_pair_syntax



subsubsection‹Results›

context comm_semigroup
begin

interpretation comm_semigroup_syntax f .

lemma left_commute[tts_ac_simps, tts_algebra_simps, field_simps]: 
  "b a (a a c) = a a (b a c)"
proof -
  have "(b a a) a c = (a a b) a c" by (simp add: commute)
  then show ?thesis by (simp only: assoc)
qed

end



subsection‹Cancellative semigroups›


subsubsection‹Definitions›


text‹Abstract cancellative semigroup.›

locale cancel_semigroup = semigroup f for f :: "'a  'a  'a" +
  assumes add_left_imp_eq: "f a b = f a c  b = c"
  assumes add_right_imp_eq: "f b a = f c a  b = c"

locale cancel_semigroup_syntax = semigroup_syntax f for f :: "'a  'a  'a"


text‹Concrete syntax.›

locale cancel_semigroup_add = cancel_semigroup plus 
  for plus :: "'a  'a  'a"
begin

sublocale semigroup_add plus ..

end

locale cancel_semigroup_mult = cancel_semigroup times 
  for times :: "'a  'a  'a"
begin

sublocale semigroup_mult times ..

end


text‹Pairs.›

locale cancel_semigroup_pair = 
  alga: cancel_semigroup fa + algb: cancel_semigroup fb 
  for fa :: "'a  'a  'a" and fb :: "'b  'b  'b"
begin

sublocale semigroup_pair fa fb ..
sublocale rev: cancel_semigroup_pair fb fa ..

end

locale cancel_semigroup_pair_syntax = semigroup_pair_syntax fa fb
  for fa :: "'a  'a  'a" and fb :: "'b  'b  'b"


subsubsection‹Results›

context cancel_semigroup
begin

interpretation cancel_semigroup_syntax f .

lemma add_left_cancel[simp]: "a a b = a a c  b = c"
  by (blast dest: add_left_imp_eq)

lemma add_right_cancel[simp]: "b a a = c a a  b = c"
  by (blast dest: add_right_imp_eq)

lemma inj_on_add[simp]: "inj_on ((⊕a) a) A" by (rule inj_onI) simp

lemma inj_on_add'[simp]: "inj_on (λb. b a a) A" by (rule inj_onI) simp

lemma bij_betw_add[simp]: "bij_betw ((⊕a) a) A B  (⊕a) a ` A = B"
  by (simp add: bij_betw_def)

end



subsection‹Cancellative commutative semigroups›


subsubsection‹Definitions›


text‹Abstract cancellative commutative semigroups.›

locale cancel_comm_semigroup = comm: comm_semigroup f + binary_op fi 
  for f fi :: "'a  'a  'a" +
  assumes add_diff_cancel_left'[simp]: "fi (f a b) a = b"
    and diff_diff_add[tts_algebra_simps, tts_field_simps]: 
    "fi (fi a b) c = fi a (f b c)"

locale cancel_comm_semigroup_syntax = comm_semigroup_syntax f + binary_op fi 
  for f fi :: "'a  'a  'a"
begin

notation fi (infixl a 65)

end


text‹Concrete syntax.›

locale cancel_comm_semigroup_add = cancel_comm_semigroup plus minus 
  for plus minus :: "'a  'a  'a"
begin

sublocale comm_semigroup_add plus ..
sublocale minus minus .

end

locale cancel_comm_semigroup_mult = cancel_comm_semigroup times divide 
  for times divide :: "'a  'a  'a"
begin

sublocale comm_semigroup_mult times ..
sublocale divide divide .

end


text‹Pairs.›

locale cancel_comm_semigroup_pair = 
  alga: cancel_comm_semigroup fa fia + algb: cancel_comm_semigroup fb fib
  for fa fia :: "'a  'a  'a" and fb fib :: "'b  'b  'b"
begin

sublocale comm_semigroup_pair fa fb ..
sublocale rev: cancel_comm_semigroup_pair fb fib fa fia ..

end

locale cancel_comm_semigroup_pair_syntax = 
  comm_semigroup_pair_syntax fa fb + binary_op fia + binary_op fib
  for fa fia fb fib
begin

notation fia (infixl a 65)
notation fib (infixl b 65)

end


subsubsection‹Results›

context cancel_comm_semigroup
begin

interpretation cancel_comm_semigroup_syntax .

lemma add_diff_cancel_right'[simp]: "(a a b) a b = a"
  using add_diff_cancel_left'[of b a] by (simp add: tts_ac_simps)

sublocale cancel: cancel_semigroup
proof
  fix a b c :: 'a
  assume "a a b = a a c"
  then have "a a b a a = a a c a a" by simp
  then show "b = c" by simp
next
  fix a b c :: 'a
  assume "b a a = c a a"
  then have "b a a a a = c a a a a" by simp
  then show "b = c" by simp
qed

lemmas cancel_semigroup_axioms = cancel.cancel_semigroup_axioms

lemma add_diff_cancel_left[simp]: "(c a a) a (c a b) = a a b"
  unfolding diff_diff_add[symmetric] by simp

lemma add_diff_cancel_right[simp]: "(a a c) a (b a c) = a a b"
  using add_diff_cancel_left[symmetric] by (simp add: tts_ac_simps)

lemma diff_right_commute: "a a c a b = a a b a c"
  by (simp add: diff_diff_add comm.commute)

end

context cancel_comm_semigroup_pair
begin

sublocale cancel: cancel_semigroup_pair ..

lemmas cancel_semigroup_pair_axioms = cancel.cancel_semigroup_pair_axioms

end

text‹\newpage›

end

Theory FNDS_Lifting_Set_Ext

(* Title: Examples/TTS_Foundations/Foundations/FNDS_Lifting_Set_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Extension of the theory text‹Lifting_Set›
theory FNDS_Lifting_Set_Ext
  imports Main
begin

context
  includes lifting_syntax
begin

lemma set_pred_eq_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A" 
  shows
    "((rel_set A ===> (=)) ===> (rel_set A ===> (=)) ===> (=)) 
      (λX Y. sCollect (Domainp A). X s = Y s) 
      ((=)::['b set  bool, 'b set  bool]  bool)"
proof(intro rel_funI)
  let ?sA = "Collect (Domainp A)"
  fix X Y :: "'a set  bool" 
  fix X' Y' :: "'b set  bool"
  assume rs: "(rel_set A ===> (=)) X X'" "(rel_set A ===> (=)) Y Y'"
  show "(s?sA. X s = Y s) = (X' = Y')"
  proof
    assume X_eq_Y: "s?sA. X s = Y s"
    {
      fix s' assume "X' s'" 
      then obtain s where "rel_set A s s'" 
        by (meson assms right_total_def right_total_rel_set)
      then have "X s" using rs(1) unfolding rel_fun_def by (simp add: X' s')
      moreover from ‹rel_set A s s' have "s  ?sA" 
        unfolding Ball_Collect[symmetric] by (auto dest: rel_setD1)
      ultimately have "Y' s'" 
        using rs(2)[unfolded rel_fun_def] ‹rel_set A s s' by (simp add: X_eq_Y)
    }
    note XY = this
    {
      fix s' assume "Y' s'" 
      then obtain s where "rel_set A s s'" 
        by (meson assms right_total_def right_total_rel_set)
      then have "Y s" using rs(2)[unfolded rel_fun_def] by (simp add: Y' s')
      moreover from ‹rel_set A s s' have "s  ?sA" 
        unfolding Ball_Collect[symmetric] by (auto dest: rel_setD1)
      ultimately have "X' s'" 
        using X_eq_Y rs(1)[unfolded rel_fun_def] ‹rel_set A s s' by auto
    }
    with XY show "X' = Y'" by auto
  next
    assume "X' = Y'" show "s?sA. X s = Y s"
      unfolding Ball_Collect[symmetric]
      using rs[unfolded rel_fun_def] X' = Y' by (metis DomainpE Domainp_set)+
  qed
qed

private lemma vimage_fst_transfer_h:
  "
  pred_prod (Domainp A) (Domainp B) x = 
    (x  Collect (Domainp A) × Collect (Domainp B))
  "
  unfolding pred_prod_beta mem_Times_iff by simp

lemma vimage_fst_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique A" "right_total A" "right_total B" 
  shows 
    "((rel_prod A B ===> A) ===> rel_set A ===> rel_set (rel_prod A B)) 
      (λf S. (f -` S)  ((Collect (Domainp A)) × (Collect (Domainp B)))) 
      vimage"
  unfolding vimage_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding vimage_fst_transfer_h by auto

lemma vimage_snd_transfer[transfer_rule]: 
  assumes [transfer_rule]: "right_total A" "bi_unique B" "right_total B" 
  shows 
    "((rel_prod A B ===> B) ===> rel_set B ===> rel_set (rel_prod A B)) 
      (λf S. (f -` S)  ((Collect (Domainp A)) × (Collect (Domainp B)))) 
      vimage"
  unfolding vimage_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding vimage_fst_transfer_h by auto

lemma vimage_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique B" "right_total A" 
  shows 
    "((A ===> B) ===> (rel_set B) ===> rel_set A) 
      (λf s. (vimage f s)  (Collect (Domainp A))) (-`)"
  by transfer_prover

lemma pairwise_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "((A ===> A ===> (=)) ===> rel_set A  ===> (=)) pairwise pairwise"
  unfolding pairwise_def by transfer_prover

lemma disjnt_transfer[transfer_rule]: 
  assumes [transfer_rule]: "bi_unique A"
  shows "(rel_set A ===> rel_set A  ===> (=)) disjnt disjnt"
  unfolding disjnt_def by transfer_prover

lemma bij_betw_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "bi_unique B"
  shows "((A ===> B) ===> rel_set A ===> rel_set B ===> (=)) bij_betw bij_betw"
  unfolding bij_betw_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

text‹\newpage›

end

Theory Set_Semigroups

(* Title: Examples/TTS_Foundations/Algebra/Set_Semigroups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section‹Abstract semigroups on sets›
theory Set_Semigroups
  imports 
    Type_Semigroups 
    FNDS_Auxiliary
    "../Foundations/FNDS_Lifting_Set_Ext"
begin



subsection‹Background›

text‹The results presented in this section were ported 
(with amendments and additions) from the theory text‹Groups› in the main 
library of Isabelle/HOL.›



subsection‹Binary operations›


text‹Abstract binary operation.›

locale binary_op_base_ow = 
  fixes U :: "'a set" and f :: "'a  'a  'a"

locale binary_op_ow = binary_op_base_ow U f for U :: "'a set" and f +
  assumes op_closed: "x  U  y  U  f x y  U"

locale binary_op_syntax_ow = binary_op_base_ow U f for U :: "'a set" and f
begin

notation f (infixl a 70)

end


text‹Concrete syntax.›

locale plus_ow = binary_op_ow U plus for U :: "'a set" and plus
begin

notation plus (infixl +a 65)

end

locale minus_ow = binary_op_ow U minus for U :: "'a set" and minus
begin

notation minus (infixl -a 65)

end

locale times_ow = binary_op_ow U times for U :: "'a set" and times
begin

notation times (infixl *a 70)

end

locale divide_ow = binary_op_ow U divide for U :: "'a set" and divide
begin

notation divide (infixl '/a 70)

end


text‹Pairs.›

locale binary_op_base_pair_ow = 
  alga: binary_op_base_ow Ua fa + algb: binary_op_base_ow Ub fb
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb

locale binary_op_pair_ow = alga: binary_op_ow Ua fa + algb: binary_op_ow Ub fb
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb
begin

sublocale binary_op_base_pair_ow Ua fa Ub fb .
sublocale rev: binary_op_base_pair_ow Ub fb Ua fa .

end

locale binary_op_pair_syntax_ow = binary_op_base_pair_ow Ua fa Ub fb
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb
begin

notation fa (infixl a 70)
notation fb (infixl b 70)

end


subsubsection‹Results›

context binary_op_ow
begin

interpretation binary_op_syntax_ow .

lemma op_closed'[simp]: "xU. yU. x a y  U" by (simp add: op_closed)

tts_register_sbts (⊕a) | U by (rule tts_AA_A_transfer[OF op_closed])

end



subsection‹Simple semigroups›


subsubsection‹Definitions›


text‹Abstract semigroup.›

locale semigroup_ow = binary_op_ow U f for U :: "'a set" and f +
  assumes assoc[tts_ac_simps]: 
    " a  U; b  U; c  U   f (f a b) c = f a (f b c)"

locale semigroup_syntax_ow = binary_op_syntax_ow U f for U :: "'a set" and f


text‹Concrete syntax.›

locale semigroup_add_ow = semigroup_ow U plus for U :: "'a set" and plus
begin

sublocale plus_ow U plus ..

end

locale semigroup_mult_ow = semigroup_ow U times for U :: "'a set" and times
begin

sublocale times_ow U times ..

end


text‹Pairs.›

locale semigroup_pair_ow = alga: semigroup_ow Ua fa + algb: semigroup_ow Ub fb 
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb
begin

sublocale binary_op_pair_ow Ua fa Ub fb ..
sublocale rev: semigroup_pair_ow Ub fb Ua fa ..

end

locale semigroup_pair_syntax_ow = binary_op_pair_syntax_ow Ua fa Ub fb
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb


subsubsection‹Transfer rules›

lemma semigroup_ow[ud_with]: "semigroup = semigroup_ow UNIV"
  unfolding 
    semigroup_def semigroup_ow_def semigroup_ow_axioms_def binary_op_ow_def
  by simp

lemma semigroup_pair_ow[ud_with]: 
  "semigroup_pair = (λfa fb. semigroup_pair_ow UNIV fa UNIV fb)"
  unfolding semigroup_pair_def semigroup_pair_ow_def ud_with by simp

context
  includes lifting_syntax
begin

lemma semigroup_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(rel_set A ===> (A ===> A ===> A) ===> (=)) semigroup_ow semigroup_ow"
  by 
    (
      ow_locale_transfer locale_defs: 
        semigroup_ow_def semigroup_ow_axioms_def binary_op_ow_def
    )

lemma semigroup_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> A) ===>  
      rel_set B ===> (B ===> B ===> B) ===> 
      (=)
    ) 
    semigroup_pair_ow semigroup_pair_ow"
  by (ow_locale_transfer locale_defs: semigroup_pair_ow_def)

end



subsection‹Commutative semigroups›


subsubsection‹Definitions›


text‹Abstract commutative semigroup.›

locale comm_semigroup_ow = semigroup_ow U f for U :: "'a set" and f +
  assumes commute[tts_ac_simps]: "a  U  b  U  f a b = f b a"

locale comm_semigroup_syntax_ow = semigroup_syntax_ow U f 
  for U :: "'a set" and f


text‹Concrete syntax.›

locale comm_semigroup_add_ow = comm_semigroup_ow U plus 
  for U :: "'a set" and plus
begin

sublocale semigroup_add_ow U plus ..

end

locale comm_semigroup_mult_ow = comm_semigroup_ow U times 
  for U :: "'a set" and times
begin

sublocale semigroup_mult_ow U times ..

end


text‹Pairs.›

locale comm_semigroup_pair_ow = 
  alga: comm_semigroup_ow Ua fa + algb: comm_semigroup_ow Ub fb  
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb
begin

sublocale semigroup_pair_ow Ua fa Ub fb ..
sublocale rev: comm_semigroup_pair_ow Ub fb Ua fa ..

end

locale comm_semigroup_pair_syntax_ow = semigroup_pair_syntax_ow Ua fa Ub fb
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb


subsubsection‹Transfer rules›

lemma comm_semigroup_ow[ud_with]: "comm_semigroup = comm_semigroup_ow UNIV"
  unfolding 
    comm_semigroup_def comm_semigroup_axioms_def
    comm_semigroup_ow_def comm_semigroup_ow_axioms_def 
    ud_with
  by simp

lemma comm_semigroup_pair_ow[ud_with]: 
  "comm_semigroup_pair = (λfa fb. comm_semigroup_pair_ow UNIV fa UNIV fb)"
  unfolding comm_semigroup_pair_def comm_semigroup_pair_ow_def ud_with 
  by simp

context
  includes lifting_syntax
begin

lemma comm_semigroup_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(rel_set A ===> (A ===> A ===> A) ===> (=)) 
      comm_semigroup_ow comm_semigroup_ow"
  by 
    (
      ow_locale_transfer locale_defs: 
        comm_semigroup_ow_def comm_semigroup_ow_axioms_def
    )

lemma comm_semigroup_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> A) ===>  
      rel_set B ===> (B ===> B ===> B) ===> 
      (=)
    ) 
    comm_semigroup_pair_ow comm_semigroup_pair_ow"
  by (ow_locale_transfer locale_defs: comm_semigroup_pair_ow_def)

end


subsubsection‹Relativization›

context comm_semigroup_ow
begin

interpretation comm_semigroup_syntax_ow .

tts_context
  tts: (?'a to U)
  substituting comm_semigroup_ow_axioms
  eliminating through auto
begin

tts_lemma left_commute:
  assumes "b  U"
    and "a  U"
    and "c  U"
  shows "b a (a a c) = a a (b a c)"
    is comm_semigroup.left_commute.

end

end



subsection‹Cancellative semigroups›


subsubsection‹Definitions›


text‹Abstract cancellative semigroup.›

locale cancel_semigroup_ow = semigroup_ow U f for U :: "'a set" and f +
  assumes add_left_imp_eq: 
    " a  U; b  U; c  U; f a b = f a c   b = c"
  assumes add_right_imp_eq: 
    " b  U; a  U; c  U; f b a = f c a   b = c"

locale cancel_semigroup_syntax_ow = semigroup_syntax_ow U f 
  for U :: "'a set" and f


text‹Concrete syntax.›

locale cancel_semigroup_add_ow = cancel_semigroup_ow U plus 
  for U :: "'a set" and plus
begin

sublocale semigroup_add_ow U plus ..

end

locale cancel_semigroup_mult_ow = cancel_semigroup_ow U times 
  for U :: "'a set" and times
begin

sublocale semigroup_mult_ow U times ..

end


text‹Pairs.›

locale cancel_semigroup_pair_ow = 
  alga: cancel_semigroup_ow Ua fa + algb: cancel_semigroup_ow Ub fb 
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb
begin

sublocale semigroup_pair_ow Ua fa Ub fb ..
sublocale rev: cancel_semigroup_pair_ow Ub fb Ua fa ..

end

locale cancel_semigroup_pair_syntax_ow = semigroup_pair_syntax_ow Ua fa Ub fb
  for Ua :: "'a set" and fa and Ub :: "'b set" and fb


subsubsection‹Transfer rules›

lemma cancel_semigroup_ow[ud_with]: 
  "cancel_semigroup = cancel_semigroup_ow UNIV"
  unfolding 
    cancel_semigroup_def cancel_semigroup_axioms_def
    cancel_semigroup_ow_def cancel_semigroup_ow_axioms_def 
    ud_with
  by simp

lemma cancel_semigroup_pair_ow[ud_with]: 
  "cancel_semigroup_pair = (λfa fb. cancel_semigroup_pair_ow UNIV fa UNIV fb)"
  unfolding cancel_semigroup_pair_def cancel_semigroup_pair_ow_def ud_with 
  by simp

context
  includes lifting_syntax
begin

lemma cancel_semigroup_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(rel_set A ===> (A ===> A ===> A) ===> (=)) 
      cancel_semigroup_ow cancel_semigroup_ow"
  by 
    (
      ow_locale_transfer locale_defs: 
        cancel_semigroup_ow_def cancel_semigroup_ow_axioms_def
    )

lemma cancel_semigroup_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> A) ===>  
      rel_set B ===> (B ===> B ===> B) ===> 
      (=)
    ) cancel_semigroup_pair_ow cancel_semigroup_pair_ow"
  by (ow_locale_transfer locale_defs: cancel_semigroup_pair_ow_def)

end


subsubsection‹Relativization›

context cancel_semigroup_ow
begin

interpretation cancel_semigroup_syntax_ow .

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_semigroup_ow_axioms
  eliminating through auto
begin

tts_lemma add_right_cancel:
  assumes "b  U" and "a  U" and "c  U"
  shows "(b a a = c a a) = (b = c)"
    is cancel_semigroup.add_right_cancel.

tts_lemma add_left_cancel:
  assumes "a  U" and "b  U" and "c  U"
  shows "(a a b = a a c) = (b = c)"
    is cancel_semigroup.add_left_cancel.    
  
tts_lemma inj_on_add':
  assumes "a  U" and "A  U"
  shows "inj_on (λb. b a a) A"
    is cancel_semigroup.inj_on_add'.

tts_lemma inj_on_add:
  assumes "a  U" and "A  U"
  shows "inj_on ((⊕a) a) A"
    is cancel_semigroup.inj_on_add.

tts_lemma bij_betw_add:
  assumes "a  U" and "A  U" and "B  U"
  shows "bij_betw ((⊕a) a) A B = ((⊕a) a ` A = B)"
    is cancel_semigroup.bij_betw_add.

end

end



subsection‹Cancellative commutative semigroups›


subsubsection‹Definitions›


text‹Abstract cancellative commutative semigroups.›

locale cancel_comm_semigroup_ow = comm_semigroup_ow U f + binary_op_ow U fi 
  for U :: "'a set" and f fi +
  assumes add_diff_cancel_left'[simp]: " a  U; b  U   fi (f a b) a = b"
    and diff_diff_add[tts_algebra_simps, tts_field_simps]: 
    " a  U; b  U; c  U   fi (fi a b) c = fi a (f b c)"

locale cancel_comm_semigroup_syntax_ow = 
  comm_semigroup_syntax_ow U f + binary_op_base_ow U fi 
  for U :: "'a set" and f fi 
begin

notation fi (infixl a 65)

end


text‹Concrete syntax.›

locale cancel_comm_semigroup_add_ow = cancel_comm_semigroup_ow U plus minus 
  for U :: "'a set" and plus minus
begin

sublocale comm_semigroup_add_ow U plus ..
sublocale minus_ow U minus ..

end

locale cancel_comm_semigroup_mult = cancel_comm_semigroup_ow U times divide 
  for U :: "'a set" and times divide
begin

sublocale comm_semigroup_mult_ow U times ..
sublocale divide_ow U divide ..

end


text‹Pairs.›

locale cancel_comm_semigroup_pair_ow = 
  alga: cancel_comm_semigroup_ow Ua fa fia + 
  algb: cancel_comm_semigroup_ow Ub fb fib
  for Ua :: "'a set" and fa fia and Ub :: "'b set" and fb fib
begin

sublocale comm_semigroup_pair_ow Ua fa Ub fb ..
sublocale rev: cancel_comm_semigroup_pair_ow Ub fb fib Ua fa fia ..

end

locale cancel_comm_semigroup_pair_syntax_ow = 
  comm_semigroup_pair_syntax_ow Ua fa Ub fb + 
  binary_op_ow Ua fia + 
  binary_op_ow Ub fib
  for Ua :: "'a set" and fa fia and Ub :: "'b set" and fb fib
begin

notation fia (infixl a 65)
notation fib (infixl b 65)

end


subsubsection‹Transfer rules›

lemma cancel_comm_semigroup_ow[ud_with]: 
  "cancel_comm_semigroup = cancel_comm_semigroup_ow UNIV"
  unfolding 
    cancel_comm_semigroup_def cancel_comm_semigroup_axioms_def
    cancel_comm_semigroup_ow_def cancel_comm_semigroup_ow_axioms_def 
    binary_op_ow_def
    ud_with
  by simp

lemma cancel_comm_semigroup_pair_ow[ud_with]: 
  "cancel_comm_semigroup_pair = 
    (λfa fia fb fib. cancel_comm_semigroup_pair_ow UNIV fa fia UNIV fb fib)"
  unfolding 
    cancel_comm_semigroup_pair_def cancel_comm_semigroup_pair_ow_def ud_with 
  by simp

context
  includes lifting_syntax
begin

lemma cancel_comm_semigroup_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A" 
  shows 
    "(rel_set A ===> (A ===> A ===> A) ===> (A ===> A ===> A) ===> (=)) 
      cancel_comm_semigroup_ow cancel_comm_semigroup_ow"
  by 
    (
      ow_locale_transfer locale_defs: 
        cancel_comm_semigroup_ow_def 
        cancel_comm_semigroup_ow_axioms_def
        binary_op_ow_def
    )

lemma cancel_comm_semigroup_pair_ow_transfer[transfer_rule]:
  assumes [transfer_rule]: 
    "bi_unique A" "right_total A" "bi_unique B" "right_total B"
  shows 
    "(
      rel_set A ===> (A ===> A ===> A) ===> (A ===> A ===> A) ===>  
      rel_set B ===> (B ===> B ===> B) ===> (B ===> B ===> B) ===> 
      (=)
    ) cancel_comm_semigroup_pair_ow cancel_comm_semigroup_pair_ow"
  by (ow_locale_transfer locale_defs: cancel_comm_semigroup_pair_ow_def)

end


subsubsection‹Relativization›

context cancel_comm_semigroup_ow
begin

interpretation cancel_comm_semigroup_syntax_ow .

tts_context
  tts: (?'a to U)
  sbterms: (?f::?'a  ?'a  ?'a to f)
    and (?fi::?'a  ?'a  ?'a to fi)
  rewriting ctr_simps
  substituting cancel_comm_semigroup_ow_axioms
  eliminating through auto
begin

tts_lemma add_diff_cancel_right':
  assumes "a  U" and "b  U"
  shows "a a b a b = a"
    is cancel_comm_semigroup.add_diff_cancel_right'.
    
tts_lemma add_diff_cancel_right:
  assumes "a  U" and "c  U" and "b  U"
  shows "a a c a b a c = a a b"
    is cancel_comm_semigroup.add_diff_cancel_right.

tts_lemma add_diff_cancel_left:
  assumes "c  U" and "a  U" and "b  U"
  shows "c a a a c a b = a a b"
    is cancel_comm_semigroup.add_diff_cancel_left.

tts_lemma diff_right_commute:
  assumes "a  U" and "c  U" and "b  U"
  shows "a a c a b = a a b a c"
    is cancel_comm_semigroup.diff_right_commute.

tts_lemma cancel_semigroup_axioms:
  assumes "U  {}"
  shows "cancel_semigroup_ow U (⊕a)"
    is cancel_comm_semigroup.cancel_semigroup_axioms.

end

sublocale cancel_semigroup_ow
  using 
    cancel_semigroup_axioms 
    cancel_semigroup_ow.intro 
    cancel_semigroup_ow_axioms_def 
    semigroup_ow_axioms 
  by auto

end

context cancel_comm_semigroup_pair_ow
begin

sublocale cancel_semigroup_pair_ow ..

end

text‹\newpage›

end

Theory FNDS_Conclusions

(* Title: Examples/TTS_Foundations/FNDS_Conclusions.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
theory FNDS_Conclusions
  imports
    FNDS_Introduction
    "./Foundations/FNDS_Set_Ext"
    "./Foundations/FNDS_Definite_Description"
    "./Orders/Type_Simple_Orders"
    "./Orders/Set_Simple_Orders"
    "./Algebra/Type_Semigroups"
    "./Algebra/Set_Semigroups"
begin
end